context("Joins")

# Univariate keys --------------------------------------------------------------

a <- data.frame(x = c(1, 1, 2, 3), y = 1:4)
b <- data.frame(x = c(1, 2, 2, 4), z = 1:4)

test_that("univariate inner join has all columns, repeated matching rows", {
  j <- inner_join(a, b, "x")

  expect_equal(names(j), c("x", "y", "z"))
  expect_equal(j$y, c(1, 2, 3, 3))
  expect_equal(j$z, c(1, 1, 2, 3))
})

test_that("univariate left join has all columns, all rows", {
  j1 <- left_join(a, b, "x")
  j2 <- left_join(b, a, "x")

  expect_equal(names(j1), c("x", "y", "z"))
  expect_equal(names(j2), c("x", "z", "y"))

  expect_equal(j1$z, c(1, 1, 2, 3, NA))
  expect_equal(j2$y, c(1, 2, 3, 3, NA))
})

test_that("univariate semi join has x columns, matching rows", {
  j1 <- semi_join(a, b, "x")
  j2 <- semi_join(b, a, "x")

  expect_equal(names(j1), c("x", "y"))
  expect_equal(names(j2), c("x", "z"))

  expect_equal(j1$y, 1:3)
  expect_equal(j2$z, 1:3)
})

test_that("univariate anti join has x columns, missing rows", {
  j1 <- anti_join(a, b, "x")
  j2 <- anti_join(b, a, "x")

  expect_equal(names(j1), c("x", "y"))
  expect_equal(names(j2), c("x", "z"))

  expect_equal(j1$y, 4)
  expect_equal(j2$z, 4)
})

test_that("univariate right join has all columns, all rows", {
  j1 <- right_join(a, b, "x")
  j2 <- right_join(b, a, "x")

  expect_equal(names(j1), c("x", "y", "z"))
  expect_equal(names(j2), c("x", "z", "y"))

  expect_equal(j1$x, c(1, 1, 2, 2, 4))
  expect_equal(j1$y, c(1, 2, 3, 3, NA))
  expect_equal(j1$z, c(1, 1, 2, 3, 4))

  expect_equal(j2$x, c(1, 1, 2, 2, 3))
  expect_equal(j2$y, c(1, 2, 3, 3, 4))
  expect_equal(j2$z, c(1, 1, 2, 3, NA))
})

# Bivariate keys ---------------------------------------------------------------

c <- data.frame(
  x = c(1, 1, 2, 3),
  y = c(1, 1, 2, 3),
  a = 1:4
)
d <- data.frame(
  x = c(1, 2, 2, 4),
  y = c(1, 2, 2, 4),
  b = 1:4
)

test_that("bivariate inner join has all columns, repeated matching rows", {
  j <- inner_join(c, d, c("x", "y"))

  expect_equal(names(j), c("x", "y", "a", "b"))
  expect_equal(j$a, c(1, 2, 3, 3))
  expect_equal(j$b, c(1, 1, 2, 3))
})

test_that("bivariate left join has all columns, all rows", {
  j1 <- left_join(c, d, c("x", "y"))
  j2 <- left_join(d, c, c("x", "y"))

  expect_equal(names(j1), c("x", "y", "a", "b"))
  expect_equal(names(j2), c("x", "y", "b", "a"))

  expect_equal(j1$b, c(1, 1, 2, 3, NA))
  expect_equal(j2$a, c(1, 2, 3, 3, NA))
})

test_that("bivariate semi join has x columns, matching rows", {
  j1 <- semi_join(c, d, c("x", "y"))
  j2 <- semi_join(d, c, c("x", "y"))

  expect_equal(names(j1), c("x", "y", "a"))
  expect_equal(names(j2), c("x", "y", "b"))

  expect_equal(j1$a, 1:3)
  expect_equal(j2$b, 1:3)
})

test_that("bivariate anti join has x columns, missing rows", {
  j1 <- anti_join(c, d, c("x", "y"))
  j2 <- anti_join(d, c, c("x", "y"))

  expect_equal(names(j1), c("x", "y", "a"))
  expect_equal(names(j2), c("x", "y", "b"))

  expect_equal(j1$a, 4)
  expect_equal(j2$b, 4)
})

# Duplicate column names --------------------------------------------------

e <- data.frame(x = c(1, 1, 2, 3), z = 1:4)
f <- data.frame(x = c(1, 2, 2, 4), z = 1:4)

test_that("univariate inner join has all columns, repeated matching rows", {
  j <- inner_join(e, f, "x")

  expect_equal(names(j), c("x", "z.x", "z.y"))
  expect_equal(j$z.x, c(1, 2, 3, 3))
  expect_equal(j$z.y, c(1, 1, 2, 3))
})

test_that("univariate left join has all columns, all rows", {
  j1 <- left_join(e, f, "x")
  j2 <- left_join(f, e, "x")

  expect_equal(names(j1), c("x", "z.x", "z.y"))
  expect_equal(names(j2), c("x", "z.x", "z.y"))

  expect_equal(j1$z.y, c(1, 1, 2, 3, NA))
  expect_equal(j2$z.y, c(1, 2, 3, 3, NA))
})

test_that("can control suffixes with suffix argument", {
  j1 <- inner_join(e, f, "x", suffix = c("1", "2"))
  j2 <- left_join(e, f, "x", suffix = c("1", "2"))
  j3 <- right_join(e, f, "x", suffix = c("1", "2"))
  j4 <- full_join(e, f, "x", suffix = c("1", "2"))

  expect_named(j1, c("x", "z1", "z2"))
  expect_named(j2, c("x", "z1", "z2"))
  expect_named(j3, c("x", "z1", "z2"))
  expect_named(j4, c("x", "z1", "z2"))
})

test_that("can handle empty string in suffix argument, left side (#2228, #2182, #2007)", {
  j1 <- inner_join(e, f, "x", suffix = c("", "2"))
  j2 <- left_join(e, f, "x", suffix = c("", "2"))
  j3 <- right_join(e, f, "x", suffix = c("", "2"))
  j4 <- full_join(e, f, "x", suffix = c("", "2"))

  expect_named(j1, c("x", "z", "z2"))
  expect_named(j2, c("x", "z", "z2"))
  expect_named(j3, c("x", "z", "z2"))
  expect_named(j4, c("x", "z", "z2"))
})

test_that("can handle empty string in suffix argument, right side (#2228, #2182, #2007)", {
  j1 <- inner_join(e, f, "x", suffix = c("1", ""))
  j2 <- left_join(e, f, "x", suffix = c("1", ""))
  j3 <- right_join(e, f, "x", suffix = c("1", ""))
  j4 <- full_join(e, f, "x", suffix = c("1", ""))

  expect_named(j1, c("x", "z1", "z"))
  expect_named(j2, c("x", "z1", "z"))
  expect_named(j3, c("x", "z1", "z"))
  expect_named(j4, c("x", "z1", "z"))
})

test_that("disallow empty string in both sides of suffix argument (#2228)", {
  expect_error(
    inner_join(e, f, "x", suffix = c("", "")),
    "`suffix` can't be empty string for both `x` and `y` suffixes",
    fixed = TRUE
  )
  expect_error(
    left_join(e, f, "x", suffix = c("", "")),
    "`suffix` can't be empty string for both `x` and `y` suffixes",
    fixed = TRUE
  )
  expect_error(
    right_join(e, f, "x", suffix = c("", "")),
    "`suffix` can't be empty string for both `x` and `y` suffixes",
    fixed = TRUE
  )
  expect_error(
    full_join(e, f, "x", suffix = c("", "")),
    "`suffix` can't be empty string for both `x` and `y` suffixes",
    fixed = TRUE
  )
})

test_that("disallow NA in any side of suffix argument", {
  expect_error(
    inner_join(e, f, "x", suffix = c(".x", NA)),
    "`suffix` can't be NA",
    fixed = TRUE
  )
  expect_error(
    left_join(e, f, "x", suffix = c(NA, ".y")),
    "`suffix` can't be NA",
    fixed = TRUE
  )
  expect_error(
    right_join(e, f, "x", suffix = c(NA_character_, NA)),
    "`suffix` can't be NA",
    fixed = TRUE
  )
  expect_error(
    full_join(e, f, "x", suffix = c("x", NA)),
    "`suffix` can't be NA",
    fixed = TRUE
  )
})

test_that("doesn't add suffix to by columns in x (#3307)", {
  j1 <- inner_join(e, f, by = c("x" = "z"))
  j2 <- left_join(e, f, by = c("x" = "z"))
  j3 <- right_join(e, f, by = c("x" = "z"))
  j4 <- full_join(e, f, by = c("x" = "z"))

  expect_named(j1, c("x", "z", "x.y"))
  expect_named(j2, c("x", "z", "x.y"))
  expect_named(j3, c("x", "z", "x.y"))
  expect_named(j4, c("x", "z", "x.y"))
})

g <- data.frame(A = 1, A.x = 2)
h <- data.frame(B = 3, A.x = 4, A = 5)

test_that("can handle 'by' columns with suffix (#3266)", {
  j1 <- inner_join(g, h, "A.x")
  j2 <- left_join(g, h, "A.x")
  j3 <- right_join(g, h, "A.x")
  j4 <- full_join(g, h, "A.x")

  expect_named(j1, c("A.x.x", "A.x", "B", "A.y"))
  expect_named(j2, c("A.x.x", "A.x", "B", "A.y"))
  expect_named(j3, c("A.x.x", "A.x", "B", "A.y"))
  expect_named(j4, c("A.x.x", "A.x", "B", "A.y"))
})

test_that("can handle 'by' columns with suffix, reverse (#3266)", {
  j1 <- inner_join(h, g, "A.x")
  j2 <- left_join(h, g, "A.x")
  j3 <- right_join(h, g, "A.x")
  j4 <- full_join(h, g, "A.x")

  expect_named(j1, c("B", "A.x", "A.x.x", "A.y"))
  expect_named(j2, c("B", "A.x", "A.x.x", "A.y"))
  expect_named(j3, c("B", "A.x", "A.x.x", "A.y"))
  expect_named(j4, c("B", "A.x", "A.x.x", "A.y"))
})

test_that("check suffix input", {
  expect_error(
    inner_join(e, f, "x", suffix = letters[1:3]),
    "`suffix` must be a character vector of length 2, not character of length 3",
    fixed = TRUE
  )
  expect_error(
    inner_join(e, f, "x", suffix = letters[1]),
    "`suffix` must be a character vector of length 2, not string of length 1",
    fixed = TRUE
  )
  expect_error(
    inner_join(e, f, "x", suffix = 1:2),
    "`suffix` must be a character vector of length 2, not integer of length 2",
    fixed = TRUE
  )
})

# Misc --------------------------------------------------------------------

test_that("inner_join does not segfault on NA in factors (#306)", {
  a <- data.frame(x = c("p", "q", NA), y = c(1, 2, 3), stringsAsFactors = TRUE)
  b <- data.frame(x = c("p", "q", "r"), z = c(4, 5, 6), stringsAsFactors = TRUE)
  expect_warning(res <- inner_join(a, b, "x"), "joining factors with different levels")
  expect_equal(nrow(res), 2L)
})

test_that("joins don't reorder columns #328", {
  a <- data.frame(a = 1:3)
  b <- data.frame(a = 1:3, b = 1, c = 2, d = 3, e = 4, f = 5)
  res <- left_join(a, b, "a")
  expect_equal(names(res), names(b))
})

test_that("join handles type promotions #123", {
  df <- data.frame(
    V1 = c(rep("a", 5), rep("b", 5)),
    V2 = rep(c(1:5), 2),
    V3 = c(101:110),
    stringsAsFactors = FALSE
  )

  match <- data.frame(
    V1 = c("a", "b"),
    V2 = c(3.0, 4.0),
    stringsAsFactors = FALSE
  )
  res <- semi_join(df, match, c("V1", "V2"))
  expect_equal(res$V2, 3:4)
  expect_equal(res$V3, c(103L, 109L))
})

test_that("indices don't get mixed up when nrow(x) > nrow(y). #365", {
  a <- data.frame(V1 = c(0, 1, 2), V2 = c("a", "b", "c"), stringsAsFactors = FALSE)
  b <- data.frame(V1 = c(0, 1), V3 = c("n", "m"), stringsAsFactors = FALSE)
  res <- inner_join(a, b, by = "V1")
  expect_equal(res$V1, c(0, 1))
  expect_equal(res$V2, c("a", "b"))
  expect_equal(res$V3, c("n", "m"))
})

test_that("join functions error on column not found #371", {
  expect_error(
    left_join(data.frame(x = 1:5), data.frame(y = 1:5), by = "x"),
    "`by` can't contain join column `x` which is missing from RHS",
    fixed = TRUE
  )
  expect_error(
    left_join(data.frame(x = 1:5), data.frame(y = 1:5), by = "y"),
    "`by` can't contain join column `y` which is missing from LHS",
    fixed = TRUE
  )
  expect_error(
    left_join(data.frame(x = 1:5), data.frame(y = 1:5)),
    "`by` required, because the data sources have no common variables",
    fixed = TRUE
  )

  expect_error(
    left_join(data.frame(x = 1:5), data.frame(y = 1:5), by = 1:3),
    "`by` must be a (named) character vector, list, or NULL for natural joins (not recommended in production code), not integer",
    fixed = TRUE
  )
})

test_that("inner_join is symmetric (even when joining on character & factor)", {
  foo <- data_frame(id = factor(c("a", "b")), var1 = "foo")
  bar <- data_frame(id = c("a", "b"), var2 = "bar")

  expect_warning(tmp1 <- inner_join(foo, bar, by = "id"), "joining factor and character")
  expect_warning(tmp2 <- inner_join(bar, foo, by = "id"), "joining character vector and factor")

  expect_is(tmp1$id, "character")
  expect_is(tmp2$id, "character")

  expect_equal(names(tmp1), c("id", "var1", "var2"))
  expect_equal(names(tmp2), c("id", "var2", "var1"))

  expect_equal(tmp1, tmp2)
})

test_that("inner_join is symmetric, even when type of join var is different (#450)", {
  foo <- tbl_df(data.frame(id = 1:10, var1 = "foo"))
  bar <- tbl_df(data.frame(id = as.numeric(rep(1:10, 5)), var2 = "bar"))

  tmp1 <- inner_join(foo, bar, by = "id")
  tmp2 <- inner_join(bar, foo, by = "id")

  expect_equal(names(tmp1), c("id", "var1", "var2"))
  expect_equal(names(tmp2), c("id", "var2", "var1"))

  expect_equal(tmp1, tmp2)
})

test_that("left_join by different variable names (#617)", {
  x <- data_frame(x1 = c(1, 3, 2))
  y <- data_frame(y1 = c(1, 2, 3), y2 = c("foo", "foo", "bar"))
  res <- left_join(x, y, by = c("x1" = "y1"))
  expect_equal(names(res), c("x1", "y2"))
  expect_equal(res$x1, c(1, 3, 2))
  expect_equal(res$y2, c("foo", "bar", "foo"))
})

test_that("joins support complex vectors", {
  a <- data.frame(x = c(1, 1, 2, 3) * 1i, y = 1:4)
  b <- data.frame(x = c(1, 2, 2, 4) * 1i, z = 1:4)
  j <- inner_join(a, b, "x")

  expect_equal(names(j), c("x", "y", "z"))
  expect_equal(j$y, c(1, 2, 3, 3))
  expect_equal(j$z, c(1, 1, 2, 3))
})

test_that("joins suffix variable names (#655)", {
  a <- data.frame(x = 1:10, y = 2:11)
  b <- data.frame(z = 5:14, x = 3:12) # x from this gets suffixed by .y
  res <- left_join(a, b, by = c("x" = "z"))
  expect_equal(names(res), c("x", "y", "x.y"))

  a <- data.frame(x = 1:10, z = 2:11)
  b <- data.frame(z = 5:14, x = 3:12) # x from this gets suffixed by .y
  res <- left_join(a, b, by = c("x" = "z"))
  expect_equal(names(res), c("x", "z", "x.y"))
})

test_that("right_join gets the column in the right order #96", {
  a <- data.frame(x = 1:10, y = 2:11)
  b <- data.frame(x = 5:14, z = 3:12)
  res <- right_join(a, b)
  expect_equal(names(res), c("x", "y", "z"))

  a <- data.frame(x = 1:10, y = 2:11)
  b <- data.frame(z = 5:14, a = 3:12)
  res <- right_join(a, b, by = c("x" = "z"))
  expect_equal(names(res), c("x", "y", "a"))
})

test_that("full_join #96", {
  a <- data.frame(x = 1:3, y = 2:4)
  b <- data.frame(x = 3:5, z = 3:5)
  res <- full_join(a, b, "x")
  expect_equal(res$x, 1:5)
  expect_equal(res$y[1:3], 2:4)
  expect_true(all(is.na(res$y[4:5])))

  expect_true(all(is.na(res$z[1:2])))
  expect_equal(res$z[3:5], 3:5)
})

test_that("JoinStringFactorVisitor and JoinFactorStringVisitor handle NA #688", {
  x <- data.frame(Greek = c("Alpha", "Beta", NA), numbers = 1:3)
  y <- data.frame(
    Greek = c("Alpha", "Beta", "Gamma"),
    Letters = c("C", "B", "C"),
    stringsAsFactors = F
  )

  expect_warning(
    res <- left_join(x, y, by = "Greek"),
    "Column `Greek` joining factor and character vector, coercing into character vector",
    fixed = TRUE
  )
  expect_true(is.na(res$Greek[3]))
  expect_true(is.na(res$Letters[3]))
  expect_equal(res$numbers, 1:3)

  expect_warning(
    res <- left_join(y, x, by = "Greek"),
    "Column `Greek` joining character vector and factor, coercing into character vector",
    fixed = TRUE
  )
  expect_equal(res$Greek, y$Greek)
  expect_equal(res$Letters, y$Letters)
  expect_equal(res$numbers[1:2], 1:2)
  expect_true(is.na(res$numbers[3]))
})

test_that("JoinFactorFactorVisitor_SameLevels preserve levels order (#675)", {
  input <- data.frame(g1 = factor(c("A", "B", "C"), levels = c("B", "A", "C")))
  output <- data.frame(
    g1 = factor(c("A", "B", "C"), levels = c("B", "A", "C")),
    g2 = factor(c("A", "B", "C"), levels = c("B", "A", "C"))
  )

  res <- inner_join(group_by(input, g1), group_by(output, g1))
  expect_equal(levels(res$g1), levels(input$g1))
  expect_equal(levels(res$g2), levels(output$g2))
})

test_that("inner_join does not reorder (#684)", {
  test <- data_frame(Greek = c("Alpha", "Beta", "Gamma"), Letters = LETTERS[1:3])
  lookup <- data_frame(Letters = c("C", "B", "C"))
  res <- inner_join(lookup, test)
  expect_equal(res$Letters, c("C", "B", "C"))
})

test_that("joins coerce factors with different levels to character (#684)", {
  d1 <- data_frame(a = factor(c("a", "b", "c")))
  d2 <- data_frame(a = factor(c("a", "e")))
  expect_warning(res <- inner_join(d1, d2))
  expect_is(res$a, "character")

  # different orders
  d2 <- d1
  attr(d2$a, "levels") <- c("c", "b", "a")
  expect_warning(res <- inner_join(d1, d2))
  expect_is(res$a, "character")
})

test_that("joins between factor and character coerces to character with a warning (#684)", {
  d1 <- data_frame(a = factor(c("a", "b", "c")))
  d2 <- data_frame(a = c("a", "e"))
  expect_warning(res <- inner_join(d1, d2))
  expect_is(res$a, "character")

  expect_warning(res <- inner_join(d2, d1))
  expect_is(res$a, "character")
})

test_that("group column names reflect renamed duplicate columns (#2330)", {
  d1 <- data_frame(x = 1:5, y = 1:5) %>% group_by(x, y)
  d2 <- data_frame(x = 1:5, y = 1:5)
  res <- inner_join(d1, d2, by = "x")
  expect_groups(d1, c("x", "y"))
  expect_groups(res, c("x", "y.x"))
})

test_that("group column names are null when joined data frames are not grouped (#2330)", {
  d1 <- data_frame(x = 1:5, y = 1:5)
  d2 <- data_frame(x = 1:5, y = 1:5)
  res <- inner_join(d1, d2, by = "x")
  expect_no_groups(res)
})

# Guessing variables in x and y ------------------------------------------------

test_that("unnamed vars are the same in both tables", {
  by1 <- common_by_from_vector(c("x", "y", "z"))
  expect_equal(by1$x, c("x", "y", "z"))
  expect_equal(by1$y, c("x", "y", "z"))

  by2 <- common_by_from_vector(c("x" = "a", "y", "z"))
  expect_equal(by2$x, c("x", "y", "z"))
  expect_equal(by2$y, c("a", "y", "z"))
})

test_that("join columns are not moved to the left (#802)", {
  df1 <- data.frame(x = 1, y = 1:5)
  df2 <- data.frame(y = 1:5, z = 2)

  out <- left_join(df1, df2)
  expect_equal(names(out), c("x", "y", "z"))
})

test_that("join can handle multiple encodings (#769)", {
  text <- c("\xC9lise", "Pierre", "Fran\xE7ois")
  Encoding(text) <- "latin1"
  x <- data_frame(name = text, score = c(5, 7, 6))
  y <- data_frame(name = text, attendance = c(8, 10, 9))
  res <- left_join(x, y, by = "name")
  expect_equal(nrow(res), 3L)
  expect_equal(res$name, x$name)

  x <- data_frame(name = factor(text), score = c(5, 7, 6))
  y <- data_frame(name = text, attendance = c(8, 10, 9))
  res <- suppressWarnings(left_join(x, y, by = "name"))
  expect_equal(nrow(res), 3L)
  expect_equal(res$name, y$name)

  x <- data_frame(name = text, score = c(5, 7, 6))
  y <- data_frame(name = factor(text), attendance = c(8, 10, 9))
  res <- suppressWarnings(left_join(x, y, by = "name"))
  expect_equal(nrow(res), 3L)
  expect_equal(res$name, x$name)

  x <- data_frame(name = factor(text), score = c(5, 7, 6))
  y <- data_frame(name = factor(text), attendance = c(8, 10, 9))
  res <- suppressWarnings(left_join(x, y, by = "name"))
  expect_equal(nrow(res), 3L)
  expect_equal(res$name, x$name)
})

test_that("join creates correctly named results (#855)", {
  x <- data.frame(q = c("a", "b", "c"), r = c("d", "e", "f"), s = c("1", "2", "3"))
  y <- data.frame(q = c("a", "b", "c"), r = c("d", "e", "f"), t = c("xxx", "xxx", "xxx"))
  res <- left_join(x, y, by = c("r", "q"))
  expect_equal(names(res), c("q", "r", "s", "t"))
  expect_equal(res$q, x$q)
  expect_equal(res$r, x$r)
})

test_that("inner join gives same result as merge by default (#1281)", {
  set.seed(75)
  x <- data.frame(
    cat1 = sample(c("A", "B", NA), 5, 1),
    cat2 = sample(c(1, 2, NA), 5, 1), v = rpois(5, 3),
    stringsAsFactors = FALSE
  )
  y <- data.frame(
    cat1 = sample(c("A", "B", NA), 5, 1),
    cat2 = sample(c(1, 2, NA), 5, 1), v = rpois(5, 3),
    stringsAsFactors = FALSE
  )
  ij <- inner_join(x, y, by = c("cat1", "cat2"))
  me <- merge(x, y, by = c("cat1", "cat2"))
  expect_true(equal_data_frame(ij, me))
})

test_that("join handles matrices #1230", {
  df1 <- data_frame(x = 1:10, text = letters[1:10])
  df2 <- data_frame(x = 1:5, text = "")
  df2$text <- matrix(LETTERS[1:10], nrow = 5)

  res <- left_join(df1, df2, by = c("x" = "x")) %>% filter(x > 5)
  text.y <- res$text.y
  expect_true(is.matrix(text.y))
  expect_equal(dim(text.y), c(5, 2))
  expect_true(all(is.na(text.y)))
})

test_that("ordering of strings is not confused by R's collate order (#1315)", {
  a <- data.frame(character = c("\u0663"), set = c("arabic_the_language"), stringsAsFactors = F)
  b <- data.frame(character = c("3"), set = c("arabic_the_numeral_set"), stringsAsFactors = F)
  res <- b %>% inner_join(a, by = c("character"))
  expect_equal(nrow(res), 0L)
  res <- a %>% inner_join(b, by = c("character"))
  expect_equal(nrow(res), 0L)
})

test_that("joins handle tzone differences (#819)", {
  date1 <- structure(-1735660800, tzone = "America/Chicago", class = c("POSIXct", "POSIXt"))
  date2 <- structure(-1735660800, tzone = "UTC", class = c("POSIXct", "POSIXt"))

  df1 <- data.frame(date = date1)
  df2 <- data.frame(date = date2)

  expect_equal(attr(left_join(df1, df1)$date, "tzone"), "America/Chicago")
})

test_that("joins matches NA in character vector by default (#892, #2033)", {
  x <- data.frame(
    id = c(NA_character_, NA_character_),
    stringsAsFactors = F
  )

  y <- expand.grid(
    id = c(NA_character_, NA_character_),
    LETTER = LETTERS[1:2],
    stringsAsFactors = F
  )

  res <- left_join(x, y, by = "id")
  expect_true(all(is.na(res$id)))
  expect_equal(res$LETTER, rep(rep(c("A", "B"), each = 2), 2))
})

test_that("joins avoid name repetition (#1460)", {
  d1 <- data.frame(id = 1:5, foo = rnorm(5))
  d2 <- data.frame(id = 1:5, foo = rnorm(5))
  d3 <- data.frame(id = 1:5, foo = rnorm(5))
  d <- d1 %>%
    left_join(d1, by = "id") %>%
    left_join(d2, by = "id") %>%
    left_join(d3, by = "id")
  expect_equal(names(d), c("id", "foo.x", "foo.y", "foo.x.x", "foo.y.y"))
})

test_that("join functions are protected against empty by (#1496)", {
  x <- data.frame()
  y <- data.frame(a = 1)
  expect_error(
    left_join(x, y, by = names(x)),
    "`by` must specify variables to join by",
    fixed = TRUE
  )
  expect_error(
    right_join(x, y, by = names(x)),
    "`by` must specify variables to join by",
    fixed = TRUE
  )
  expect_error(
    semi_join(x, y, by = names(x)),
    "`by` must specify variables to join by",
    fixed = TRUE
  )
  expect_error(
    full_join(x, y, by = names(x)),
    "`by` must specify variables to join by",
    fixed = TRUE
  )
  expect_error(
    anti_join(x, y, by = names(x)),
    "`by` must specify variables to join by",
    fixed = TRUE
  )
  expect_error(
    inner_join(x, y, by = names(x)),
    "`by` must specify variables to join by",
    fixed = TRUE
  )
})

test_that("joins takes care of duplicates in by (#1192)", {
  data2 <- data_frame(a = 1:3)
  data1 <- data_frame(a = 1:3, c = 3:5)

  res1 <- left_join(data1, data2, by = c("a", "a"))
  res2 <- left_join(data1, data2, by = c("a" = "a"))
  expect_equal(res1, res2)
})

# Joined columns result in correct type ----------------------------------------

test_that("result of joining POSIXct is POSIXct (#1578)", {
  data1 <- data_frame(
    t = seq(as.POSIXct("2015-12-01", tz = "UTC"), length.out = 2, by = "days"),
    x = 1:2
  )
  data2 <- inner_join(data1, data1, by = "t")
  res1 <- class(data2$t)
  expected <- c("POSIXct", "POSIXt")
  expect_identical(res1, expected)
})

test_that("joins allows extra attributes if they are identical (#1636)", {
  tbl_left <- data_frame(
    i = rep(c(1, 2, 3), each = 2),
    x1 = letters[1:6]
  )
  tbl_right <- data_frame(
    i = c(1, 2, 3),
    x2 = letters[1:3]
  )

  attr(tbl_left$i, "label") <- "iterator"
  attr(tbl_right$i, "label") <- "iterator"

  res <- left_join(tbl_left, tbl_right, by = "i")
  expect_equal(attr(res$i, "label"), "iterator")

  attr(tbl_left$i, "foo") <- "bar"
  attributes(tbl_right$i) <- NULL
  attr(tbl_right$i, "foo") <- "bar"
  attr(tbl_right$i, "label") <- "iterator"

  res <- left_join(tbl_left, tbl_right, by = "i")
  expect_equal(attr(res$i, "label"), "iterator")
  expect_equal(attr(res$i, "foo"), "bar")
})

test_that("joins work with factors of different levels (#1712)", {
  d1 <- iris[, c("Species", "Sepal.Length")]
  d2 <- iris[, c("Species", "Sepal.Width")]
  d2$Species <- factor(as.character(d2$Species), levels = rev(levels(d1$Species)))
  expect_warning(res1 <- left_join(d1, d2, by = "Species"))

  d1$Species <- as.character(d1$Species)
  d2$Species <- as.character(d2$Species)
  res2 <- left_join(d1, d2, by = "Species")
  expect_equal(res1, res2)
})

test_that("anti and semi joins give correct result when by variable is a factor (#1571)", {
  big <- data.frame(letter = rep(c("a", "b"), each = 2), number = 1:2)
  small <- data.frame(letter = "b")
  expect_warning(
    aj_result <- anti_join(big, small, by = "letter"),
    "Column `letter` joining factors with different levels, coercing to character vector",
    fixed = TRUE
  )
  expect_equal(aj_result$number, 1:2)
  expect_equal(aj_result$letter, factor(c("a", "a"), levels = c("a", "b")))

  expect_warning(
    sj_result <- semi_join(big, small, by = "letter"),
    "Column `letter` joining factors with different levels, coercing to character vector",
    fixed = TRUE
  )
  expect_equal(sj_result$number, 1:2)
  expect_equal(sj_result$letter, factor(c("b", "b"), levels = c("a", "b")))
})

test_that("inner join not crashing (#1559)", {
  df3 <- data_frame(
    id = c(102, 102, 102, 121),
    name = c("qwer", "qwer", "qwer", "asdf"),
    k = factor(c("one", "two", "total", "one"), levels = c("one", "two", "total")),
    total = factor(c("tot", "tot", "tot", "tot"), levels = c("tot", "plan", "fact")),
    v = c(NA_real_, NA_real_, NA_real_, NA_real_),
    btm = c(25654.957609, 29375.7547216667, 55030.7123306667, 10469.3523273333),
    top = c(22238.368946, 30341.516924, 52579.88587, 9541.893144)
  )
  df4 <- data_frame(
    id = c(102, 102, 102, 121),
    name = c("qwer", "qwer", "qwer", "asdf"),
    k = factor(c("one", "two", "total", "one"), levels = c("one", "two", "total")),
    type = factor(c("fact", "fact", "fact", "fact"), levels = c("tot", "plan", "fact")),
    perc = c(0.15363485835208, -0.0318297270618471, 0.0466114830816894, 0.0971986553754823)
  )
  # all we want here is to test that this does not crash
  expect_message(res <- replicate(100, df3 %>% inner_join(df4)))
  for (i in 2:100) expect_equal(res[, 1], res[, i])
})

# Encoding ----------------------------------------------------------------

test_that("join handles mix of encodings in data (#1885, #2118, #2271)", {
  with_non_utf8_encoding({
    special <- get_native_lang_string()

    for (factor1 in c(FALSE, TRUE)) {
      for (factor2 in c(FALSE, TRUE)) {
        for (encoder1 in c(enc2native, enc2utf8)) {
          for (encoder2 in c(enc2native, enc2utf8)) {
            df1 <- data.frame(x = encoder1(special), y = 1, stringsAsFactors = factor1)
            df1 <- tbl_df(df1)
            df2 <- data.frame(x = encoder2(special), z = 2, stringsAsFactors = factor2)
            df2 <- tbl_df(df2)
            df <- data.frame(x = special, y = 1, z = 2, stringsAsFactors = factor1 && factor2)
            df <- tbl_df(df)

            info <- paste(
              factor1,
              factor2,
              Encoding(as.character(df1$x)),
              Encoding(as.character(df2$x))
            )

            if (factor1 != factor2) {
              warning_msg <- "coercing"
            } else {
              warning_msg <- NA
            }

            expect_warning_msg <- function(code, msg = warning_msg) {
              expect_warning(
                code, msg,
                info = paste(deparse(substitute(code)[[2]][[1]]), info)
              )
            }

            expect_equal_df <- function(code, df_ = df) {
              code <- substitute(code)
              eval(bquote(
                expect_equal(
                  .(code), df_,
                  info = paste(deparse(code[[1]]), info)
                )
              ))
            }

            expect_warning_msg(expect_equal_df(inner_join(df1, df2, by = "x")))
            expect_warning_msg(expect_equal_df(left_join(df1, df2, by = "x")))
            expect_warning_msg(expect_equal_df(right_join(df1, df2, by = "x")))
            expect_warning_msg(expect_equal_df(full_join(df1, df2, by = "x")))
            expect_warning_msg(
              expect_equal_df(
                semi_join(df1, df2, by = "x"),
                data.frame(x = special, y = 1, stringsAsFactors = factor1)
              )
            )
            expect_warning_msg(
              expect_equal_df(
                anti_join(df1, df2, by = "x"),
                data.frame(x = special, y = 1, stringsAsFactors = factor1)[0, ]
              )
            )
          }
        }
      }
    }
  })
})

test_that("left_join handles mix of encodings in column names (#1571)", {
  with_non_utf8_encoding({
    special <- get_native_lang_string()

    df1 <- data_frame(x = 1:6, foo = 1:6)
    names(df1)[1] <- special

    df2 <- data_frame(x = 1:6, baz = 1:6)
    names(df2)[1] <- enc2native(special)

    expect_message(res <- left_join(df1, df2), special, fixed = TRUE)
    expect_equal(names(res), c(special, "foo", "baz"))
    expect_equal(res$foo, 1:6)
    expect_equal(res$baz, 1:6)
    expect_equal(res[[special]], 1:6)
  })
})

# Misc --------------------------------------------------------------------

test_that("NAs match in joins only with na_matches = 'na' (#2033)", {
  df1 <- data_frame(a = NA)
  df2 <- data_frame(a = NA, b = 1:3)
  for (na_matches in c("na", "never")) {
    accept_na_match <- (na_matches == "na")
    expect_equal(inner_join(df1, df2, na_matches = na_matches) %>% nrow(), 0 + 3 * accept_na_match)
    expect_equal(left_join(df1, df2, na_matches = na_matches) %>% nrow(), 1 + 2 * accept_na_match)
    expect_equal(right_join(df2, df1, na_matches = na_matches) %>% nrow(), 1 + 2 * accept_na_match)
    expect_equal(full_join(df1, df2, na_matches = na_matches) %>% nrow(), 4 - accept_na_match)
    expect_equal(anti_join(df1, df2, na_matches = na_matches) %>% nrow(), 1 - accept_na_match)
    expect_equal(semi_join(df1, df2, na_matches = na_matches) %>% nrow(), 0 + accept_na_match)
  }
})

test_that("joins regroups (#1597, #3566)", {
  df1 <- data_frame(a = 1:3) %>% group_by(a)
  df2 <- data_frame(a = rep(1:4, 2)) %>% group_by(a)

  expect_grouped <- function(df) {
    expect_true(is_grouped_df(df))
  }

  expect_grouped(inner_join(df1, df2))
  expect_grouped(left_join(df1, df2))
  expect_grouped(right_join(df2, df1))
  expect_grouped(full_join(df1, df2))
  expect_grouped(anti_join(df1, df2))
  expect_grouped(semi_join(df1, df2))
})

test_that("join accepts tz attributes (#2643)", {
  # It's the same time:
  df1 <- data_frame(a = as.POSIXct("2009-01-01 10:00:00", tz = "Europe/London"))
  df2 <- data_frame(a = as.POSIXct("2009-01-01 11:00:00", tz = "Europe/Paris"))
  result <- inner_join(df1, df2, by = "a")
  expect_equal(nrow(result), 1)
})

test_that("join takes LHS with warning if attributes inconsistent", {
  df1 <- tibble(a = 1:2, b = 2:1)
  df2 <- tibble(
    a = structure(1:2, foo = "bar"),
    c = 2:1
  )

  expect_warning(
    out1 <- left_join(df1, df2, by = "a"),
    "Column `a` has different attributes on LHS and RHS of join"
  )
  expect_warning(out2 <- left_join(df2, df1, by = "a"))
  expect_warning(
    out3 <- left_join(df1, df2, by = c("b" = "a")),
    "Column `b`/`a` has different attributes on LHS and RHS of join"
  )

  expect_equal(attr(out1$a, "foo"), NULL)
  expect_equal(attr(out2$a, "foo"), "bar")
})

test_that("common_by() message", {
  df <- tibble(!!!set_names(letters, letters))

  expect_message(
    left_join(df, df %>% select(1)),
    'Joining, by = "a"',
    fixed = TRUE
  )

  expect_message(
    left_join(df, df %>% select(1:3)),
    'Joining, by = c("a", "b", "c")',
    fixed = TRUE
  )

  expect_message(
    left_join(df, df),
    paste0("Joining, by = c(", paste0('"', letters, '"', collapse = ", "), ")"),
    fixed = TRUE
  )
})

test_that("semi- and anti-joins preserve order (#2964)", {
  expect_identical(
    data_frame(a = 3:1) %>% semi_join(data_frame(a = 1:3)),
    data_frame(a = 3:1)
  )
  expect_identical(
    data_frame(a = 3:1) %>% anti_join(data_frame(a = 4:6)),
    data_frame(a = 3:1)
  )
})

test_that("join handles raw vectors", {
  df1 <- data_frame(r = as.raw(1:4), x = 1:4)
  df2 <- data_frame(r = as.raw(3:6), y = 3:6)

  expect_identical(
    left_join(df1, df2, by = "r"),
    data_frame(r = as.raw(1:4), x = 1:4, y = c(NA, NA, 3:4))
  )

  expect_identical(
    right_join(df1, df2, by = "r"),
    data_frame(r = as.raw(3:6), x = c(3:4, NA, NA), y = c(3:6))
  )

  expect_identical(
    full_join(df1, df2, by = "r"),
    data_frame(r = as.raw(1:6), x = c(1:4, NA, NA), y = c(NA, NA, 3:6))
  )

  expect_identical(
    inner_join(df1, df2, by = "r"),
    data_frame(r = as.raw(3:4), x = c(3:4), y = c(3:4))
  )
})

test_that("nest_join works (#3570)",{
  df1 <- tibble(x = c(1, 2), y = c(2, 3))
  df2 <- tibble(x = c(1, 1), z = c(2, 3))
  res <- nest_join(df1, df2, by = "x")
  expect_equal(names(res), c(names(df1), "df2"))
  expect_identical(res$df2[[1]], select(df2, z))
  expect_identical(res$df2[[2]], tibble(z = double()))
})

test_that("nest_join handles multiple matches in x (#3642)", {
  df1 <- tibble(x = c(1, 1))
  df2 <- tibble(x = 1, y = 1:2)

  tbls <- df1 %>%
    nest_join(df2) %>%
    pull()

  expect_identical(tbls[[1]], tbls[[2]])
})

test_that("joins reject data frames with duplicate columns (#3243)", {
  df1 <- data.frame(x1 = 1:3, x2 = 1:3, y = 1:3)
  names(df1)[1:2] <- "x"
  df2 <- data.frame(x = 2:4, y = 2:4)

  expect_error(
    left_join(df1, df2, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    left_join(df2, df1, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    right_join(df1, df2, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    right_join(df2, df1, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    inner_join(df1, df2, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    inner_join(df2, df1, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    full_join(df1, df2, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    full_join(df2, df1, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    semi_join(df1, df2, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  # FIXME: Compatibility, should throw an error eventually
  expect_warning(
    expect_equal(
      semi_join(df2, df1, by = c("x", "y")),
      data.frame(x = 2:3, y = 2:3)
    ),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  expect_error(
    anti_join(df1, df2, by = c("x", "y")),
    "Column `x` must have a unique name",
    fixed = TRUE
  )

  # FIXME: Compatibility, should throw an error eventually
  expect_warning(
    expect_equal(
      anti_join(df2, df1, by = c("x", "y")),
      data.frame(x = 4L, y = 4L)
    ),
    "Column `x` must have a unique name",
    fixed = TRUE
  )
})

test_that("joins reject data frames with NA columns (#3417)", {
  df_a <- tibble(B = c("a", "b", "c"), AA = 1:3)
  df_b <- tibble(AA = 2:4, C = c("aa", "bb", "cc"))

  df_aa <- df_a
  names(df_aa) <- c(NA, "AA")
  df_ba <- df_b
  names(df_ba) <- c("AA", NA)

  expect_error(
    left_join(df_aa, df_b),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_error(
    left_join(df_aa, df_ba),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_error(
    left_join(df_a, df_ba),
    "Column `2` cannot have NA as name",
    fixed = TRUE
  )

  expect_error(
    right_join(df_aa, df_b),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_error(
    right_join(df_aa, df_ba),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_error(
    right_join(df_a, df_ba),
    "Column `2` cannot have NA as name",
    fixed = TRUE
  )

  expect_error(
    inner_join(df_aa, df_b),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_error(
    inner_join(df_aa, df_ba),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_error(
    inner_join(df_a, df_ba),
    "Column `2` cannot have NA as name",
    fixed = TRUE
  )

  expect_error(
    full_join(df_aa, df_b),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_error(
    full_join(df_aa, df_ba),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_error(
    full_join(df_a, df_ba),
    "Column `2` cannot have NA as name",
    fixed = TRUE
  )

  expect_warning(
    semi_join(df_aa, df_b),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_warning(
    semi_join(df_aa, df_ba),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_warning(
    semi_join(df_a, df_ba),
    "Column `2` cannot have NA as name",
    fixed = TRUE
  )

  expect_warning(
    anti_join(df_aa, df_b),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_warning(
    anti_join(df_aa, df_ba),
    "Column `1` cannot have NA as name",
    fixed = TRUE
  )
  expect_warning(
    anti_join(df_a, df_ba),
    "Column `2` cannot have NA as name",
    fixed = TRUE
  )
})


library(bigrquery)
library(zipcode)
library(tidyverse)
library(ggplot2)
library(rgdal)
library(rgeos)
library(maptools)
library(viridis)
library(lubridate)
library(RColorBrewer)
library(reshape2)
library(tidycensus)
library(sp)
library(sf)
library(tigris)
library(rmapshaper)

# us_leg_dist_projection<- CRS("+proj=longlat +ellps=GRS80 +datum=NAD83 +no_defs")
#https://www.nceas.ucsb.edu/scicomp/usecases/point-in-polygon

# Install your census api key for tidycensus
#census_api_key("xxxxxxxxxxxxxxxxxxxxxxx", install=TRUE)

#code to get all of the geom files for a country (or large region defined by totalpop_sf) in one sf object
us <- unique(fips_codes$state)[1:51]

totalpop_sf <- reduce(
  map(us, function(x) {
    # get_acs does not yet support congr distr geometry
    #    get_acs(geography = "congressional districts", variables = "B01003_001",
    get_acs(geography = "tract", variables = "B01003_001",
            state = x, geometry = TRUE)
  }),
  rbind
)

# Import shapefile as and sf dataframe
cd_115<- st_read(dsn="examples/geofiles/us_legislative_districts", layer="cb_2017_us_cd115_500k", quiet=TRUE)

# Filter to the state we're interested in
MN_cd_115 <- filter(cd_115, STATEFP == "27")

# Convert to an simple features dataframe
coordinates(MN_2018_download) <- c("client_lon", "client_lat")
MN2018_down_sf <- st_as_sf(MN_2018_download)

coordinates(MN_2018_upload) <- c("client_lon", "client_lat")
MN2018_up_sf <- st_as_sf(MN_2018_upload)

# Set the layer CRSs to be the same
st_crs(MN2018_down_sf) <- st_crs(MN_cd_115)
st_crs(MN2018_up_sf) <- st_crs(MN_cd_115)

# do spatial join to add congressional district to speed test rows
MN_2018_down_cd115 <- bind_cols(
  MN_2018_download@data,
  MN_cd_115[as.numeric(st_within(MN2018_down_sf, MN_cd_115)),]
)
MN_2018_up_cd115 <- bind_cols(
  MN_2018_upload@data,
  MN_cd_115[as.numeric(st_within(MN2018_up_sf, MN_cd_115)),]
)

# First summary of median download speed to reduce sample bias
#   This first step produces download speed medians by district, day, and client_ip, reducing potential sample bias from
#   multiple tests from the same ip addresses over time
MN_2018_DL_IP_day_district <- MN_2018_down_cd115 %>%
  group_by(CD115FP,format(as.Date(log_time), "%Y-%m-%d"),client_ip) %>%
  summarize(median_dl = median(download_speed_Mbps))

MN_2018_UL_IP_day_district <- MN_2018_up_cd115 %>%
  group_by(CD115FP,format(as.Date(log_time), "%Y-%m-%d"),client_ip) %>%
  summarize(median_ul = median(upload_speed_Mbps))

# Rename the 'day' column generated by the transform of log_time in the previous DF
names(MN_2018_DL_IP_day_district)[2] = "day"
names(MN_2018_UL_IP_day_district)[2] = "day"

# Second and final summary of median download speed by district
#   This second summarization groups the previously calculated medians by district, day, and client_ip to simply medians by district
MN_2018_download_median_cd115 <- MN_2018_DL_IP_day_district %>%
  group_by(CD115FP) %>%
  summarize(median_download_Mbps = median(median_dl))

MN_2018_upload_median_cd115 <- MN_2018_UL_IP_day_district %>%
  group_by(CD115FP) %>%
  summarize(median_upload_Mbps = median(median_ul))

# Rejoin the geometry field so we can map median speeds by district
MN_2018_DL_median_ip_day_district <- left_join(MN_2018_download_median_cd115, MN_cd_115, by=c("CD115FP"))
MN_2018_UL_median_ip_day_district <- left_join(MN_2018_upload_median_cd115, MN_cd_115, by=c("CD115FP"))

# Do the mapping with ggplot
MN_2018_median_down_cd115_plot <- MN_2018_DL_median_ip_day_district %>%
  ggplot(aes(fill=median_download_Mbps),color=median_download_Mbps) +
  guides(fill=guide_legend(title="Median Download Speed (Mbps)")) +
  theme_bw() +
  theme(panel.background = element_rect(fill= NA), panel.grid = element_blank(), panel.border = element_blank(),
        panel.grid.major = element_line(colour = "white"), panel.grid.minor = element_line(colour = "white"),
        axis.text = element_blank(), axis.ticks = element_blank() ) +
  geom_sf() +
  geom_text(centroids.MNdist, label=id, x = "lon", y = "lat")

MN_2018_median_up_cd115_plot <- MN_2018_UL_median_ip_day_district %>%
  ggplot(aes(fill=median_upload_Mbps),color=median_upload_Mbps) + geom_sf()

districts <- readOGR(dsn="examples/geofiles/us_legislative_districts", layer="cb_2017_us_cd115_500k",stringsAsFactors = FALSE)
MN_districts <- districts[districts$STATEFP=="27",]
idList <- MN_districts@data$CD115FP
centroids.districts <- as.data.frame(coordinates(MN_districts))
centroids.MNdist <- as.data.frame(coordinates(MN_districts), MN_districts@data$CD115FP)

test.df <- data.frame(id=idList, centroids.districts)

geom_col(mapping = NULL, data = NULL, position = "stack", ...,
         width = NULL, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE)


# Copyright Syncfusion Inc. 2001 - 2016. All rights reserved.
# Use of this code is subject to the terms of our license.
# A copy of the current license can be obtained at any time by e-mailing
# licensing@syncfusion.com. Any infringement will be prosecuted under
# applicable laws.

# If you are not familiar with R you can obtain a quick introduction by downloading
# R Succinctly for free from Syncfusion - http://www.syncfusion.com/resources/techportal/ebooks/rsuccinctly
# R Succinctly is also included with this installation and is available here
# Installed Drive :\Program Files (x86)\Syncfusion\Essential Studio\XX.X.X.XX\Infrastructure\EBooks\R_Succintly.pdf OF R Succinctly
# Uncomment below lines to install necessary packages if not installed already
#install.packages("gbm")
#install.packages("devtools")
#install.packages("rJava")
# install.packages("caret")
#install.packages("githubinstall")
#Use 'r2pmml' package version v0.3.0 or below since, the function 'tdist' has been deprecated in later versions.
#library(githubinstall)
#gh_install_packages("jpmml/r2pmml", ref="0.3.0")

# Load below packages
library(caret) # This package is specifically loaded for Cars dataset shipped within it.
library(devtools)
library(gbm)
library(rJava)
library(r2pmml)

# Here we directly load the cars dataset installed with the "caret" package.
data(cars)

# rename column names in cars dataset from caret package
carsOriginal <- setNames(cars, c("Price", "Mileage", "Cylinder", "Doors", "Cruise", "Sound", "Leather", "Buick", "Cadillac", "Chevy", "Pontiac", "Saab", "Saturn",
"Convertible", "Coupe", "Hatchback", "Sedan", "Wagon"))

# Omit rows with missing values
carsOriginal = na.omit(carsOriginal)

# Code below demonstrates loading the same dataset from a CSV file shipped with our installer.
# Please check installed samples (Data) location to set actual working directory
# Uncomment below lines and comment out the code to read data from CSV file.
# setwd("C:/actual_data_location")
# cars= read.csv("Cars.csv")

# Divide dataset for training and test
trainData<-carsOriginal[1:643,]
testData<-carsOriginal[644:804,]

# Applying the GBM - tdist function to predict cens
cars_GBM =  gbm(Price~., data=trainData,distribution="tdist")

# Display the predicted results
# Predict "Price" column probability for test data set
carsTestProbabilities =predict.gbm(cars_GBM, newdata=testData, n.trees=100,type="response")
# Display predicted probabilities
carsTestProbabilities

# PMML generated will be of version v4.2 since, older version(v0.3.0) 'r2pmml' has been loaded.
r2pmml(cars_GBM,"Cars.pmml")

# The code below is used for evaluation purpose.
# The model is applied for original cars data set and predicted results are saved in "ROutput.csv"
# "ROutput.csv" file used for comparing the R results with PMML Evaluation engine results

# Applying General Regression model to entire dataset and save the results in a CSV file
carsEntireProbabilities = predict.gbm(cars_GBM,carsOriginal,n.trees=100,type="response")

# Save predicted value in a data frame
result = data.frame(carsEntireProbabilities)
names(result) = c("Predicted_RetailPrice")

# Write the results in a CSV file
write.csv(result,"ROutput.csv",quote=F)


## directory for outputs (plots, csv files, etc.)
output.dir <- "output-20210811"

## consider at most the top 1000 associations reported by each study
top.n <- 1000 ##  p_rank in sql query <= 1000

library(Cairo)
library(readr)
library(randomcoloR)

## package for saving the outputs of computations
## install: devtools::install_github("perishky/eval.save")
library(eval.save)
eval.save.dir(".eval")

## load Hannah's phenotype groups
source("https://raw.githubusercontent.com/hannah-e/collapse_EWAS_catalog_phenotypes/main/functional_analysis_regroup_EWAS_catalogue_phenotypes.R")
## out: EWAS_catalog
groups <- unique(EWAS_catalog[,c("StudyID","phenotype")])
colnames(groups) <- c("study","group")

## read number of overlapping associations per study
overlaps <- read.table(file.path(output.dir, "overlaps.txt"), sep="\t", stringsAsFactors=F, header=T)

overlaps$n1 <- as.integer(overlaps$n1)
overlaps$n2 <- as.integer(overlaps$n2)

overlaps$n1 <- pmin(top.n, overlaps$n1)
overlaps$n2 <- pmin(top.n, overlaps$n2)

## calculate overlap significance using fisher's exact test
## for each pair of studies
n <- 485000
overlaps$ff <- n - overlaps$n1 - overlaps$n2 + overlaps$overlap
overlaps$tt <- overlaps$overlap
overlaps$tf <- overlaps$n1 - overlaps$overlap
overlaps$ft <- overlaps$n2 - overlaps$overlap
overlaps$p <- eval.save({
  apply(overlaps[,c("ff","ft","tf","tt")], 1, function(vals) {
      tryCatch(
          fisher.test(matrix(vals, ncol=2), alternative="greater")$p.value
          , error=function(e) NA)
  })
}, "overlaps-p") ## 20 minutes

## add symmetric comparisons
overlaps.r <- overlaps
overlaps.r$study1 <- overlaps.r$study2
overlaps.r$n1 <- overlaps.r$n2
overlaps.r$study2 <- overlaps$study1
overlaps.r$n2 <- overlaps$n1
overlaps.r$p <- overlaps$p
overlaps <- rbind(overlaps, overlaps.r)

## create 'overlap.p', matrix of fisher exact test p-values
studies <- unique(c(overlaps$study1, overlaps$study2))
overlap.p <- matrix(NA, ncol=length(studies), nrow=length(studies),
                   dimnames=list(studies, studies))
idx <- cbind(r=match(overlaps$study1, rownames(overlap.p)),
             c=match(overlaps$study2, colnames(overlap.p)))
overlap.p[idx] <- overlaps$p

## calculate log of overlap p-values
log.p <- -log(overlap.p,10)
log.p[which(log.p > 50)] <- 50

## Bonferroni adjusted -log(p-value) threshold
threshold <- -log(0.05/length(log.p)*2, 10)
threshold
## [1] 7.664473

## plot heatmap of log.p
source("heatmap-function.r")

CairoPNG(file.path(output.dir, "heatmap.png"),
         width=16384, height=16384)
plot.new()
grid.clip()

cols <- heatmap.color.scheme(
    low.breaks=seq(0,threshold,length.out=50),
    high.breaks=seq(threshold,max(log.p,na.rm=T),length.out=50))

all.groups <- sort(unique(groups[,"group"]))
group.cols <- data.frame(
    group=all.groups,
    col=rainbow(length(all.groups)))
study.cols <- data.frame(
    study=colnames(log.p),
    group=groups$group[match(colnames(log.p), groups$study)])
study.cols$col <- group.cols$col[match(study.cols$group,group.cols$group)]
clinical <- matrix(study.cols$col, nrow=1)
rownames(clinical) <- "phenotype group"

h.out <- heatmap.simple(log.p,
                        color.scheme=cols,
                        key.min=0,
			key.max=max(log.p, na.rm=T),
			na.color="gray",
			scale="none",
                        clinical=clinical,
                        title="EWAS catalog clustering") ## 5 minutes

dev.off()

## replace missing p-values with p=1
log.p[is.na(log.p)] <- 0

## use networks to identify clusters of studies (louvain clustering)
## VD Blondel, J-L
##     Guillaume, R Lambiotte and E Lefebvre: Fast unfolding of community
##     hierarchies in large networks, <URL:
##     http://arxiv.org/abs/arXiv:0803.0476>
weights <- log.p
weights[which(weights < -log(1e-4,10))] <- 0

library(igraph)
graph <- graph_from_adjacency_matrix(weights,
                                     mode="undirected",
                                     weighted=T,
                                     diag=F)
clusters <- cluster_louvain(graph)

length(clusters)
## [1] 699

## break the graph unto subgraphs corresponding to clusters
subgraphs <- lapply(1:length(clusters), function(i)
                   induced_subgraph(graph, which(membership(clusters)==i)))

## compare edge weights (i.e. log p-values)
## between nodes/studies in the same
## cluster versus elsewhere
subgraphs.weights <- lapply(subgraphs, function(g) E(g)$weight)
subgraphs.weights <- unlist(subgraphs.weights)
quantile(E(graph)$weight)
quantile(subgraphs.weights)
## > quantile(E(graph)$weight)
##        0%       25%       50%       75%      100%
##  4.000195  5.083681  7.675126 14.748110 50.000000
## > quantile(subgraphs.weights)
##        0%       25%       50%       75%      100%
##  4.000510  5.208620  9.235719 19.081418 50.000000

## show sizes of clusters and median -log(p-value) per cluster
ret <- t(sapply(subgraphs, function(g) {
    c(n=length(V(g)),
      median.weight = median(sapply(V(g), function(v) {
          median(incident(g,v)$weight, na.rm=T)
      })))
}))
ret <- ret[order(ret[,"n"],decreasing=T),]
ret[ret[,"n"] > 4,]
##        n median.weight
##  [1,] 328      6.608221
##  [2,] 305      8.307027
##  [3,] 192     11.945131
##  [4,] 143      8.381339
##  [5,]  92     16.468290
##  [6,]  79     34.567194
##  [7,]  36      6.513009
##  [8,]  19      5.083682
##  [9,]  12     21.595919
## [10,]  11      9.766727
## [11,]  10     26.784681
## [12,]  10     47.299716
## [13,]   9      5.384712
## [14,]   9     12.937390
## [15,]   8      5.573377
## [16,]   8      4.796666
## [17,]   7      9.514150
## [18,]   6     14.759602
## [19,]   5      5.384712
## [20,]   5      5.685741
## [21,]   5     50.000000
## [22,]   5     17.197919

## median number of neighbors ('deg') within each cluster
ret <- cbind(n=sapply(subgraphs, vcount),
             deg=sapply(subgraphs, function(g) median(degree(g))))
ret <- ret[order(ret[,"n"],decreasing=T),]
ret[ret[,"n"] > 4,]
##        n  deg
##  [1,] 328 90.0
##  [2,] 305  6.0
##  [3,] 192 81.0
##  [4,] 143 54.0
##  [5,]  92 59.0
##  [6,]  79 66.0
##  [7,]  36  3.5
##  [8,]  19  2.0
##  [9,]  12  9.0
## [10,]  11  8.0
## [11,]  10  3.5
## [12,]  10  7.0
## [13,]   9  3.0
## [14,]   9  5.0
## [15,]   8  2.0
## [16,]   8  4.0
## [17,]   7  2.0
## [18,]   6  1.0
## [19,]   5  3.0
## [20,]   5  4.0
## [21,]   5  4.0
## [22,]   5  2.0

clusters <- do.call(rbind, lapply(1:length(subgraphs), function(i) {
    data.frame(cluster=i,
               cluster.size=length(V(subgraphs[[i]])),
               study=names(V(subgraphs[[i]])))
}))
clusters$group <- groups$group[match(clusters$study, groups$study)]

write.csv(clusters, file=file.path(output.dir, "louvain-clusters.csv"), row.names=F)


#################################################################################
## File Name: v3_Analysis_TimeSeries.R                                         ##
## Date: 27 APr 2016                                                           ##
## Author: Gento Kato                                                          ##
## Project: Foreign Image News Project                                         ##
## Purpose: Conduct Time Series Analysis                                       ##
#################################################################################

## For Jupyter Notebook (Ignore if Using Other Software) ##
library(IRdisplay)

display_html(
'<script>
code_show=true;
function code_toggle() {
  if (code_show){
    $(\'div.input\').hide();
  } else {
    $(\'div.input\').show();
  }
  code_show = !code_show
}
$( document ).ready(code_toggle);
</script>
  <form action="javascript:code_toggle()">
    <input type="submit" value="Click here to toggle on/off the raw code.">
 </form>'
)

## Suppress Warning
#options(warn=-1)
#options(warn=0) # put it back

#################
## Preparation ##
#################

## Clear Workspace
rm(list=ls())

## Library Required Packages
library(rprojroot); library(doBy); library(descr)

##################Prepare Packages##################
library(vars)#;detach("package:vars", unload=TRUE)
library(tseries);library(urca);
library(tsDyn)#;detach("package:tsDyn", unload=TRUE)
#library(MSBVAR);detach("package:MSBVAR", unload=TRUE)
#library(FIAR);
####################################################
library(ggplot2)

## Set Working Directory (Automatically or Manually) ##
projdir <- find_root(has_file("README.md")); projdir; setwd(projdir) #In Atom
#setwd(dirname(rstudioapi::getActiveDocumentContext()$path)); setwd("../") #In RStudio
#setwd("C:/GoogleDrive/Projects/Agenda-Setting Persuasion Framing/Foreign_Image_News_Project/codes")

#######################
## Load Monthly Data ##
#######################

load("data/v3_Data5_MonthlySubset.Rdata")

ls()

#############################
## Agenda Setting Analysis ##
#############################

## Data #######################################

stv <- min(which(!is.na(usmonth$imprel)))
edv <- max(which(!is.na(usmonth$imprel)))

## Create Data ##
attach(usmonth[stv:edv,])
usimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(usmonth[stv:edv,])
attach(chnmonth[stv:edv,])
chnimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(chnmonth[stv:edv,])
attach(skormonth[stv:edv,])
skorimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(skormonth[stv:edv,])
attach(nkormonth[stv:edv,])
nkorimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(nkormonth[stv:edv,])
attach(rusmonth[stv:edv,])
rusimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(rusmonth[stv:edv,])
attach(euromonth[stv:edv,])
euroimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(euromonth[stv:edv,])
attach(mneastmonth[stv:edv,])
mneastimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(mneastmonth[stv:edv,])
attach(taiwanmonth[stv:edv,])
taiwanimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(taiwanmonth[stv:edv,])
attach(seasiamonth[stv:edv,])
seasiaimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(seasiamonth[stv:edv,])
attach(msamericamonth[stv:edv,])
msamericaimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(msamericamonth[stv:edv,])
attach(oceaniamonth[stv:edv,])
oceaniaimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(oceaniamonth[stv:edv,])
attach(africamonth[stv:edv,])
africaimp<-data.frame(trade_gdp,statecount_w_both_per,imprel)
detach(africamonth[stv:edv,])

## ADF Test (Non-Stationary Variable Exists for All Except for US)
# US
summary(ur.df(usimp$imprel,type="trend",selectlags="AIC")) ## Stationary
summary(ur.df(usimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(usimp$trade_gdp,type="drift",selectlags="AIC")) ## Stationary
# China
summary(ur.df(chnimp$imprel,type="trend",selectlags="AIC")) ## Non-Stationary (10%)
summary(ur.df(diff(chnimp$imprel),type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(chnimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(chnimp$trade_gdp,type="trend",selectlags="AIC")) ## Stationary
# S.Korea
summary(ur.df(skorimp$imprel,type="drift",selectlags="AIC")) ## Non-Stationary (1%)
summary(ur.df(diff(skorimp$imprel),type="none",selectlags="AIC")) ## Stationary
summary(ur.df(skorimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(skorimp$trade_gdp,type="trend",selectlags="AIC")) ## Non-Stationary (5%)
summary(ur.df(diff(skorimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationary
# N.Korea
summary(ur.df(nkorimp$imprel,type="trend",selectlags="AIC")) ## Non-Stationary (10%)
summary(ur.df(diff(nkorimp$imprel),type="drift",selectlags="AIC")) # Stationary
summary(ur.df(nkorimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(nkorimp$trade_gdp,type="trend",selectlags="AIC")) ## None-Stationary (5%)
summary(ur.df(diff(nkorimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationary
# Russia
summary(ur.df(rusimp$imprel,type="trend",selectlags="AIC")) ## Stationary
summary(ur.df(rusimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(rusimp$trade_gdp,type="trend",selectlags="AIC")) ## Non-Stationary (5%)
summary(ur.df(diff(rusimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationary
# Europe
summary(ur.df(euroimp$imprel,type="trend",selectlags="AIC")) ## Stationary
summary(ur.df(euroimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(euroimp$trade_gdp,type="trend",selectlags="AIC")) ## Non-Stationary (5%)
summary(ur.df(diff(euroimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationary
# Middle-Near East
summary(ur.df(mneastimp$imprel,type="trend",selectlags="AIC")) ## Stationary
summary(ur.df(mneastimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(mneastimp$trade_gdp,type="trend",selectlags="AIC")) ## Non-Stationary (1%)
summary(ur.df(diff(mneastimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationary
# Taiwan
summary(ur.df(taiwanimp$imprel,type="trend",selectlags="AIC")) ## Non-Stationary (1%)
summary(ur.df(diff(taiwanimp$imprel),type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(taiwanimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(taiwanimp$trade_gdp,type="trend",selectlags="AIC")) ## Non-Stationary (1%)
summary(ur.df(diff(taiwanimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationary
# South-East Asia
summary(ur.df(seasiaimp$imprel,type="trend",selectlags="AIC")) ## Non-Stationary (10%)
summary(ur.df(diff(seasiaimp$imprel),type="none",selectlags="AIC")) ## Stationary
summary(ur.df(seasiaimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(seasiaimp$trade_gdp,type="trend",selectlags="AIC")) ## Stationary
# Middle-South America
summary(ur.df(msamericaimp$imprel,type="trend",selectlags="AIC")) ## Stationary
summary(ur.df(msamericaimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(msamericaimp$trade_gdp,type="trend",selectlags="AIC")) ## Non-Stationary (1%)
summary(ur.df(diff(msamericaimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationary
# Oceania
summary(ur.df(oceaniaimp$imprel,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(oceaniaimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(oceaniaimp$trade_gdp,type="trend",selectlags="AIC")) ## Non-Stationary (1%)
summary(ur.df(diff(oceaniaimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationary
# Africa
summary(ur.df(africaimp$imprel,type="trend",selectlags="AIC")) ## Stationary
summary(ur.df(africaimp$statecount_w_both_per,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(africaimp$trade_gdp,type="trend",selectlags="AIC")) ## Non-Stationary (5%)
summary(ur.df(diff(africaimp$trade_gdp),type="drift",selectlags="AIC")) ## Stationry

# Optimal Lag Based on AIC
usIp <- VARselect(usimp,lag.max=12, type="both")$selection[1]; usIp # 3
chnIp <- VARselect(chnimp,lag.max=12, type="both")$selection[1]; chnIp # 12
skorIp <- VARselect(skorimp,lag.max=12, type="both")$selection[1]; skorIp # 4
nkorIp <- VARselect(nkorimp,lag.max=12, type="both")$selection[1]; nkorIp # 4
rusIp <- VARselect(rusimp,lag.max=12, type="both")$selection[1]; rusIp # 6
euroIp <- VARselect(euroimp,lag.max=12, type="both")$selection[1]; euroIp # 7
mneastIp <- VARselect(mneastimp,lag.max=12, type="both")$selection[1]; mneastIp # 3
taiwanIp <- VARselect(taiwanimp,lag.max=12, type="both")$selection[1]; taiwanIp # 5
seasiaIp <- VARselect(seasiaimp,lag.max=12, type="both")$selection[1]; seasiaIp # 7
msamericaIp <- VARselect(msamericaimp,lag.max=12, type="both")$selection[1]; msamericaIp # 3
oceaniaIp <- VARselect(oceaniaimp,lag.max=12, type="both")$selection[1]; oceaniaIp # 7
africaIp <- VARselect(africaimp,lag.max=12, type="both")$selection[1]; africaIp # 5

# VECM with Cointegration Trace Test (Cointegration Exists for All *This is Used)
usimp.vecm <- ca.jo(usimp, ecdet="const", type='trace', K=usIp, spec="transitory"); summary(usimp.vecm) # 2
chnimp.vecm <- ca.jo(chnimp, ecdet="const", type='trace', K=chnIp, spec="transitory"); summary(chnimp.vecm) # 2
skorimp.vecm <- ca.jo(skorimp, ecdet="const", type='trace', K=skorIp, spec="transitory"); summary(skorimp.vecm) # 1
nkorimp.vecm <- ca.jo(nkorimp, ecdet="const", type='trace', K=nkorIp, spec="transitory"); summary(nkorimp.vecm) # 2
rusimp.vecm <- ca.jo(rusimp, ecdet="const", type='trace', K=rusIp, spec="transitory"); summary(rusimp.vecm) # 1
euroimp.vecm <- ca.jo(euroimp, ecdet="const", type='trace', K=euroIp, spec="transitory"); summary(euroimp.vecm) # 1
mneastimp.vecm <- ca.jo(mneastimp, ecdet="const", type='trace', K=mneastIp, spec="transitory"); summary(mneastimp.vecm) # 2
taiwanimp.vecm <- ca.jo(taiwanimp, ecdet="const", type='trace', K=taiwanIp, spec="transitory"); summary(taiwanimp.vecm) #1
seasiaimp.vecm <- ca.jo(seasiaimp, ecdet="const", type='trace', K=seasiaIp, spec="transitory"); summary(seasiaimp.vecm) # 1
msamericaimp.vecm <- ca.jo(msamericaimp, ecdet="const", type='trace', K=msamericaIp, spec="transitory"); summary(msamericaimp.vecm) # 2
oceaniaimp.vecm <- ca.jo(oceaniaimp, ecdet="const", type='trace', K=oceaniaIp, spec="transitory"); summary(oceaniaimp.vecm) # 1
africaimp.vecm <- ca.jo(africaimp, ecdet="const", type='trace', K=africaIp, spec="transitory"); summary(africaimp.vecm) # 1

# Cointegration  Maximal Eigenvalue Test (Result Identical: not used for the final analysis)
# summary(ca.jo(usimp, ecdet="const", type='eigen', K=usIp, spec="transitory")) # 2
# summary(ca.jo(chnimp, ecdet="const", type='eigen', K=chnIp, spec="transitory")) # 2
# summary(ca.jo(skorimp, ecdet="const", type='eigen', K=skorIp, spec="transitory")) # 1
# summary(ca.jo(nkorimp, ecdet="const", type='eigen', K=nkorIp, spec="transitory")) # 2
# summary(ca.jo(rusimp, ecdet="const", type='eigen', K=rusIp, spec="transitory")) # 1
# summary(ca.jo(euroimp, ecdet="const", type='eigen', K=euroIp, spec="transitory")) # 1
# summary(ca.jo(mneastimp, ecdet="const", type='eigen', K=mneastIp, spec="transitory")) # 2
# summary(ca.jo(taiwanimp, ecdet="const", type='eigen', K=taiwanIp, spec="transitory")) # 1
# summary(ca.jo(seasiaimp, ecdet="const", type='eigen', K=seasiaIp, spec="transitory")) # 1
# summary(ca.jo(msamericaimp, ecdet="const", type='eigen', K=msamericaIp, spec="transitory")) # 2
# summary(ca.jo(oceaniaimp, ecdet="const", type='eigen', K=oceaniaIp, spec="transitory")) # 1
# summary(ca.jo(africaimp, ecdet="const", type='eigen', K=africaIp, spec="transitory")) # 1

## Restrictions for Short Run Matrix
SR <- matrix(NA,nrow=3,ncol=3); SR[1,2:3] <- 0; SR[2,3] <- 0
## NO Restrictions for Long Run Matrix
LR <- matrix(NA,nrow=3,ncol=3)

## Structural VECM Result
usimp.vecm.res <- SVEC(usimp.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE,boot=FALSE,runs=500)
chnimp.vecm.res <- SVEC(chnimp.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE,boot=FALSE,runs=500)
skorimp.vecm.res <- SVEC(skorimp.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE,boot=FALSE,runs=500)
nkorimp.vecm.res <- SVEC(nkorimp.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE,boot=FALSE,runs=500)
rusimp.vecm.res <- SVEC(rusimp.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE,boot=FALSE,runs=500)
euroimp.vecm.res <- SVEC(euroimp.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE,boot=FALSE,runs=500)
mneastimp.vecm.res <- SVEC(mneastimp.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE,boot=FALSE,runs=500)
taiwanimp.vecm.res <- SVEC(taiwanimp.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE,boot=FALSE,runs=500)
seasiaimp.vecm.res <- SVEC(seasiaimp.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE,boot=FALSE,runs=500)
msamericaimp.vecm.res <- SVEC(msamericaimp.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE,boot=FALSE,runs=500)
oceaniaimp.vecm.res <- SVEC(oceaniaimp.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE,boot=FALSE,runs=500)
africaimp.vecm.res <- SVEC(africaimp.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE,boot=FALSE,runs=500)

## IRF
usirf<-irf(usimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
chnirf<-irf(chnimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
skorirf<-irf(skorimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
nkorirf<-irf(nkorimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
rusirf<-irf(rusimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
euroirf<-irf(euroimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
mneastirf<-irf(mneastimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
taiwanirf<-irf(taiwanimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
seasiairf<-irf(seasiaimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
msamericairf<-irf(msamericaimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
oceaniairf<-irf(oceaniaimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)
africairf<-irf(africaimp.vecm.res,n.ahead=12,ci=0.95,runs=1000)

# plot(usirf) # small
# plot(chnirf) # none
# plot(skorirf) # good short term
# plot(nkorirf) # good and persistent
# plot(rusirf) # good short term
# plot(euroirf) # small short term
# plot(mneastirf) # small short term
# plot(taiwanirf) # small short term
# plot(seasiairf) # no effect
# plot(msamericairf) # small
# plot(oceaniairf) # none
# plot(africairf) # none

################################
## Framing and Agenda-Setting ##
################################

attach(usmonth[stv:edv,])
usimp_frame<-data.frame(trade_gdp,defense_w_both_per2,econ_w_both_per2,imprel)
detach(usmonth[stv:edv,])
attach(chnmonth[stv:edv,])
chnimp_frame<-data.frame(trade_gdp,defense_w_both_per2,econ_w_both_per2,imprel)
detach(chnmonth[stv:edv,])
attach(skormonth[stv:edv,])
skorimp_frame<-data.frame(trade_gdp,defense_w_both_per2,econ_w_both_per2,imprel)
detach(skormonth[stv:edv,])
attach(nkormonth[stv:edv,])
nkorimp_frame<-data.frame(trade_gdp,defense_w_both_per2,econ_w_both_per2,imprel)
detach(nkormonth[stv:edv,])

## ADF Test (All new Variables are stationary)
# US
summary(ur.df(usimp_frame$econ_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(usimp_frame$defense_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
# China
summary(ur.df(chnimp_frame$econ_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(chnimp_frame$defense_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
# S.Korea
summary(ur.df(skorimp_frame$econ_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(skorimp_frame$defense_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
# N.Korea
summary(ur.df(nkorimp_frame$econ_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(nkorimp_frame$defense_w_both_per2,type="drift",selectlags="AIC")) ## Stationary

# Optimal Lag Based on AIC
usIFp <- VARselect(usimp_frame,lag.max=12, type="both")$selection[1]; usIFp; usIFp=2 # 1
chnIFp <- VARselect(chnimp_frame,lag.max=12, type="both")$selection[1]; chnIFp # 2
skorIFp <- VARselect(skorimp_frame,lag.max=12, type="both")$selection[1]; skorIFp # 2
nkorIFp <- VARselect(nkorimp_frame,lag.max=12, type="both")$selection[1]; nkorIFp # 4

# VECM with Cointegration Trace Test (Cointegration Exists for All *This is Used)
usimpF.vecm <- ca.jo(usimp_frame, ecdet="const", type='trace', K=usIFp, spec="transitory"); summary(usimpF.vecm) # 3
chnimpF.vecm <- ca.jo(chnimp_frame, ecdet="const", type='trace', K=chnIFp, spec="transitory"); summary(chnimpF.vecm) # 2
skorimpF.vecm <- ca.jo(skorimp_frame, ecdet="const", type='trace', K=skorIFp, spec="transitory"); summary(skorimpF.vecm) # 2
nkorimpF.vecm <- ca.jo(nkorimp_frame, ecdet="const", type='trace', K=nkorIFp, spec="transitory"); summary(nkorimpF.vecm) # 2

## Restrictions for Short Run Matrix
SR <- matrix(NA,nrow=4,ncol=4); SR[1,2:4]<-0; SR[2,3:4]<-0; SR[3,4]<-0; #SR[3,2]<-0
## NO Restrictions for Long Run Matrix
LR <- matrix(NA,nrow=4,ncol=4)

## VECM Result
usimpF.vecm.res <- SVEC(usimpF.vecm,LR=LR,SR=SR,r=3,lrtest=FALSE)
chnimpF.vecm.res <- SVEC(chnimpF.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE) #,boot=TRUE,runs=500
skorimpF.vecm.res <- SVEC(skorimpF.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE) #,boot=TRUE,runs=500
nkorimpF.vecm.res <- SVEC(nkorimpF.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE) #,boot=TRUE,runs=500

## IRF
usirf_frame<-irf(usimpF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
chnirf_frame<-irf(chnimpF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
skorirf_frame<-irf(skorimpF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
nkorirf_frame<-irf(nkorimpF.vecm.res,n.ahead=12,ci=0.95,runs=1000)

# plot(usirf_frame)
# plot(chnirf_frame)
# plot(skorirf_frame)
# plot(nkorirf_frame)

###############################
## Persuasion (Like/Dislike) ##
###############################

attach(usmonth)
usldl<-data.frame(surplus_gdp,statetone_w_both_per2,ldlstate)[-nrow(usmonth),]
detach(usmonth)
attach(chnmonth)
chnldl<-data.frame(surplus_gdp,statetone_w_both_per2,ldlstate)[-nrow(chnmonth),]
detach(chnmonth)
attach(skormonth)
skorldl<-data.frame(surplus_gdp,statetone_w_both_per2,ldlstate)[-nrow(skormonth),]
detach(skormonth)
attach(nkormonth)
nkorldl<-data.frame(surplus_gdp,statetone_w_both_per2,ldlstate)[-nrow(nkormonth),]
detach(nkormonth)

## ADF Test
# US
summary(ur.df(usldl$ldlstate,type="trend",selectlags="AIC")) ## Non-Stationary (10%)
summary(ur.df(diff(usldl$ldlstate),type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(usldl$statetone_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(usldl$surplus_gdp,type="trend",selectlags="AIC")) ## Stationary
# China
summary(ur.df(chnldl$ldlstate,type="trend",selectlags="AIC")) ## Non-Stationary (10%)
summary(ur.df(diff(chnldl$ldlstate),type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(chnldl$statetone_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(chnldl$surplus_gdp,type="trend",selectlags="AIC")) ## Stationary
# S.Korea
summary(ur.df(skorldl$ldlstate,type="trend",selectlags="AIC")) ## Non-Stationary (10%)
summary(ur.df(diff(skorldl$ldlstate),type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(skorldl$statetone_w_both_per2,type="none",selectlags="AIC")) ## Stationary
summary(ur.df(skorldl$surplus_gdp,type="trend",selectlags="AIC")) ## Stationary
# N.Korea
summary(ur.df(nkorldl$ldlstate,type="trend",selectlags="AIC")) ## Non-Stationary (5%)
summary(ur.df(diff(nkorldl$ldlstate),type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(nkorldl$statetone_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(nkorldl$surplus_gdp,type="none",selectlags="AIC")) ## Stationary

# Optimal Lag Based on AIC
usTp <- VARselect(usldl,lag.max=12, type="both")$selection[1]; usTp # 12
chnTp <- VARselect(chnldl,lag.max=12, type="both")$selection[1]; chnTp # 12
skorTp <- VARselect(skorldl,lag.max=12, type="both")$selection[1]; skorTp # 12
nkorTp <- VARselect(nkorldl,lag.max=12, type="both")$selection[1]; nkorTp # 4

# VECM with Cointegration Trace Test (Cointegration Exists for All *This is Used)
usldl.vecm <- ca.jo(usldl, ecdet="const", type='trace', K=usTp, spec="transitory"); summary(usldl.vecm) # 1
chnldl.vecm <- ca.jo(chnldl, ecdet="const", type='trace', K=chnTp, spec="transitory"); summary(chnldl.vecm) # 1
skorldl.vecm <- ca.jo(skorldl, ecdet="const", type='trace', K=skorTp, spec="transitory"); summary(skorldl.vecm) # 1
nkorldl.vecm <- ca.jo(nkorldl, ecdet="const", type='trace', K=nkorTp, spec="transitory"); summary(nkorldl.vecm) # 2

## Restrictions for Short Run Matrix
SR <- matrix(NA,nrow=3,ncol=3); SR[1,2:3] <- 0; SR[2,3] <- 0
## NO Restrictions for Long Run Matrix
LR <- matrix(NA,nrow=3,ncol=3)

## Structural VECM Result
usldl.vecm.res <- SVEC(usldl.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE)
chnldl.vecm.res <- SVEC(chnldl.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE) #,boot=TRUE,runs=500
skorldl.vecm.res <- SVEC(skorldl.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE) #,boot=TRUE,runs=500
nkorldl.vecm.res <- SVEC(nkorldl.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE) #,boot=TRUE,runs=500

## IRF
usirf_ldl<-irf(usldl.vecm.res,n.ahead=12,ci=0.95,runs=1000)
chnirf_ldl<-irf(chnldl.vecm.res,n.ahead=12,ci=0.95,runs=1000)
skorirf_ldl<-irf(skorldl.vecm.res,n.ahead=12,ci=0.95,runs=1000)
nkorirf_ldl<-irf(nkorldl.vecm.res,n.ahead=12,ci=0.95,runs=1000)

# plot(usirf_ldl)
# plot(chnirf_ldl)
# plot(skorirf_ldl)
# plot(nkorirf_ldl)

#############################
## Persuasion (ldl, frame) ##
#############################

attach(usmonth)
usldl_frame<-data.frame(surplus_gdp,tonedefense_w_both_per2,toneecon_w_both_per2,ldlstate)[-nrow(usmonth),]
detach(usmonth)
attach(chnmonth)
chnldl_frame<-data.frame(surplus_gdp,tonedefense_w_both_per2,toneecon_w_both_per2,ldlstate)[-nrow(chnmonth),]
detach(chnmonth)
attach(skormonth)
skorldl_frame<-data.frame(surplus_gdp,tonedefense_w_both_per2,toneecon_w_both_per2,ldlstate)[-nrow(skormonth),]
detach(skormonth)
attach(nkormonth)
nkorldl_frame<-data.frame(surplus_gdp,tonedefense_w_both_per2,toneecon_w_both_per2,ldlstate)[-nrow(nkormonth),]
detach(nkormonth)

## ADF Test (All new Variables are stationary)
# US
summary(ur.df(usldl_frame$toneecon_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(usldl_frame$tonedefense_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
# China
summary(ur.df(chnldl_frame$toneecon_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(chnldl_frame$tonedefense_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
# S.Korea
summary(ur.df(skorldl_frame$toneecon_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(skorldl_frame$tonedefense_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
# N.Korea
summary(ur.df(nkorldl_frame$toneecon_w_both_per2,type="drift",selectlags="AIC")) ## Stationary
summary(ur.df(nkorldl_frame$tonedefense_w_both_per2,type="drift",selectlags="AIC")) ## Stationary

# Optimal Lag Based on AIC
usTFp <- VARselect(usldl_frame,lag.max=12, type="both")$selection[1]; usTFp # 12
chnTFp <- VARselect(chnldl_frame,lag.max=12, type="both")$selection[1]; chnTFp # 3
skorTFp <- VARselect(skorldl_frame,lag.max=12, type="both")$selection[1]; skorTFp; skorTFp=2 # 1
nkorTFp <- VARselect(nkorldl_frame,lag.max=12, type="both")$selection[1]; nkorTFp # 4

# VECM with Cointegration Trace Test (Cointegration Exists for All *This is Used)
usldlF.vecm <- ca.jo(usldl_frame, ecdet="const", type='trace', K=usTFp, spec="transitory"); summary(usldlF.vecm) # 2
chnldlF.vecm <- ca.jo(chnldl_frame, ecdet="const", type='trace', K=chnTFp, spec="transitory"); summary(chnldlF.vecm) # 1
skorldlF.vecm <- ca.jo(skorldl_frame, ecdet="const", type='trace', K=skorTFp, spec="transitory"); summary(skorldlF.vecm) # 2
nkorldlF.vecm <- ca.jo(nkorldl_frame, ecdet="const", type='trace', K=nkorTFp, spec="transitory"); summary(nkorldlF.vecm) # 3

## Restrictions for Short Run Matrix
SR <- matrix(NA,nrow=4,ncol=4); SR[1,2:4]<-0; SR[2,3:4]<-0; SR[3,4]<-0; #SR[3,2]<-0
## NO Restrictions for Long Run Matrix
LR <- matrix(NA,nrow=4,ncol=4)

## VECM Result
usldlF.vecm.res <- SVEC(usldlF.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE)
chnldlF.vecm.res <- SVEC(chnldlF.vecm,LR=LR,SR=SR,r=1,lrtest=FALSE) #,boot=TRUE,runs=500
skorldlF.vecm.res <- SVEC(skorldlF.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE) #,boot=TRUE,runs=500
nkorldlF.vecm.res <- SVEC(nkorldlF.vecm,LR=LR,SR=SR,r=3,lrtest=FALSE) #,boot=TRUE,runs=500

## IRF
usirf_ldl_frame<-irf(usldlF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
chnirf_ldl_frame<-irf(chnldlF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
skorirf_ldl_frame<-irf(skorldlF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
nkorirf_ldl_frame<-irf(nkorldlF.vecm.res,n.ahead=12,ci=0.95,runs=1000)

# plot(usirf_ldl_frame) # small
# plot(chnirf_ldl_frame) # none
# plot(skorirf_ldl_frame) # good short term
# plot(nkorirf_ldl_frame) # good and persistent

###########################################
## Persuasion (ldl, frame by frequency ) ##
###########################################

# Create Datasets
attach(usmonth)
usldlI_frame<-data.frame(surplus_gdp,defense_w_both_per2,econ_w_both_per2,ldlstate)[-nrow(usmonth),]
detach(usmonth)
attach(chnmonth)
chnldlI_frame<-data.frame(surplus_gdp,defense_w_both_per2,econ_w_both_per2,ldlstate)[-nrow(usmonth),]
detach(chnmonth)
attach(skormonth)
skorldlI_frame<-data.frame(surplus_gdp,defense_w_both_per2,econ_w_both_per2,ldlstate)[-nrow(usmonth),]
detach(skormonth)
attach(nkormonth)
nkorldlI_frame<-data.frame(surplus_gdp,defense_w_both_per2,econ_w_both_per2,ldlstate)[-nrow(usmonth),]
detach(nkormonth)

# Optimal Lag Based on AIC
usTIFp <- VARselect(usldlI_frame,lag.max=12, type="both")$selection[1]; usTIFp # 12
chnTIFp <- VARselect(chnldlI_frame,lag.max=12, type="both")$selection[1]; chnTIFp # 12
skorTIFp <- VARselect(skorldlI_frame,lag.max=12, type="both")$selection[1]; skorTIFp; skorTIFp=2 # 1 (Changed to 2)
nkorTIFp <- VARselect(nkorldlI_frame,lag.max=12, type="both")$selection[1]; nkorTIFp # 3

# VECM with Cointegration Trace Test (Cointegration Exists for All *This is Used)
usldlIF.vecm <- ca.jo(usldlI_frame, ecdet="const", type='trace', K=usTIFp, spec="transitory"); summary(usldlIF.vecm) # 2
chnldlIF.vecm <- ca.jo(chnldlI_frame, ecdet="const", type='trace', K=chnTIFp, spec="transitory"); summary(chnldlIF.vecm) # 2
skorldlIF.vecm <- ca.jo(skorldlI_frame, ecdet="const", type='trace', K=skorTIFp, spec="transitory"); summary(skorldlIF.vecm) # 2
nkorldlIF.vecm <- ca.jo(nkorldlI_frame, ecdet="const", type='trace', K=nkorTIFp, spec="transitory"); summary(nkorldlIF.vecm) # 3

## Restrictions for Short Run Matrix
SR <- matrix(NA,nrow=4,ncol=4); SR[1,2:4]<-0; SR[2,3:4]<-0; SR[3,4]<-0; #SR[3,2]<-0
## NO Restrictions for Long Run Matrix
LR <- matrix(NA,nrow=4,ncol=4)

## SVECM Result
usldlIF.vecm.res <- SVEC(usldlIF.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE)
chnldlIF.vecm.res <- SVEC(chnldlIF.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE) #,boot=TRUE,runs=500
skorldlIF.vecm.res <- SVEC(skorldlIF.vecm,LR=LR,SR=SR,r=2,lrtest=FALSE) #,boot=TRUE,runs=500
nkorldlIF.vecm.res <- SVEC(nkorldlIF.vecm,LR=LR,SR=SR,r=3,lrtest=FALSE) #,boot=TRUE,runs=500

usirf_ldlI_frame<-irf(usldlIF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
chnirf_ldlI_frame<-irf(chnldlIF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
skorirf_ldlI_frame<-irf(skorldlIF.vecm.res,n.ahead=12,ci=0.95,runs=1000)
nkorirf_ldlI_frame<-irf(nkorldlIF.vecm.res,n.ahead=12,ci=0.95,runs=1000)

# plot(usirf_ldlI_frame) # small
# plot(chnirf_ldlI_frame) # none
# plot(skorirf_ldlI_frame) # good short term
# plot(nkorirf_ldlI_frame) # good and persistent

######################################
## Save Result (separate from data) ##
######################################

## Remove Data from Work Space ##
rm(usmonth, chnmonth, skormonth, nkormonth, rusmonth, euromonth, mneastmonth, #indiamonth,
   taiwanmonth, seasiamonth, msamericamonth, oceaniamonth, africamonth)

## Save the Remaining Analytical Result ##
save.image("./outputs/v3_Analysis_TimeSeries.RData")
#load("./outputs/v3_Analysis_TimeSeries.RData")


## amp_rarecurve function from https://github.com/MadsAlbertsen/ampvis2/blob/master/R/amp_rarecurve.R ###

#' Calculate rarefaction curve for each sample.
#'
#' Calculate rarefaction curve for each sample using the vegan rarecurve function directly from a phyloseq object.
#'
#' @usage amp_rarecurve(data)
#'
#' @param data (required) A phyloseq object.
#' @param step Step size for sample sizes in rarefaction curves (default: 100).
#' @param ylim vector of y-axis limits.
#' @param xlim vector of x-axis limits.
#' @param label Label rarefaction curves (default: F).
#' @param color Color lines by metadata.
#' @param color.vector Vector with colors e.g. c("red","white") (default: NULL).
#' @param legend Add a legend to the plot if color is used (default: T).
#' @param legend.position Position of the legend (default: "topleft").
#'
#' @export
#' @import phyloseq
#' @import vegan
#'
#' @author Mads Albertsen \email{MadsAlbertsen85@@gmail.com}

amp_rarecurve <- function(data, step = 100, ylim = NULL, xlim = NULL, label = F, color = NULL, legend = T, color.vector = NULL, legend.position = "topleft"){

  abund = otu_table(data)@.Data %>% as.data.frame()

  if (!is.null(color)) {
    gg_color_hue <- function(n) {
      hues = seq(15, 375, length=n+1)
      hcl(h=hues, l=65, c=100)[1:n]
    }
    group_vector<-sample_data(data)[,color]@.Data %>% as.data.frame()
    names(group_vector)<-"color_variable"
    group_vector<-as.character(group_vector$color_variable)
    groups<-unique(group_vector)
    n = length(groups)
    cols = gg_color_hue(n)
    if (!is.null(color.vector)){ cols <- color.vector}

    col_vector<-rep("black",length(group_vector))
    for (i in 1:length(group_vector)){
      col_vector[i]<-cols[match(group_vector[i],groups)]
    }
  } else {
    col_vector = "black"
  }

  if (is.null(ylim) & is.null(xlim)){
    rarecurve(t(abund), step = step, label = label, col = col_vector)
  }
  if (!is.null(ylim) & !is.null(xlim)){
    rarecurve(t(abund), step = step, ylim = ylim, xlim = xlim, label = label, col = col_vector)
  }
  if (!is.null(ylim) & is.null(xlim)){
    rarecurve(t(abund), step = step, ylim = ylim, label = label, col = col_vector)
  }
  if (is.null(ylim) & !is.null(xlim)){
    rarecurve(t(abund), step = step, xlim = xlim, label = label, col = col_vector)
  }

  if (!is.null(color) & legend == T){
    legend(legend.position,legend = groups,fill = cols, bty = "n")
  }
}


# 4. faza: Analiza podatkov
#Uporabljeni grafi

ggplot(podatki) + aes(tournamentRegionName=tournamentRegionName, teamName=teamName, x=rating, y=goal, color=tournamentRegionName) + geom_point(stat="identity") +
  labs(x="Rating", y="Dani goli v sezoni", colour="država") + geom_smooth(aes(group=tournamentRegionName), method="lm", se=FALSE)

ggplot(podatki) + aes(tournamentRegionName=tournamentRegionName, teamName=teamName, x=shotsPerGame, y=goalPerGame, color=tournamentRegionName) + geom_point(stat="identity") +
  labs(x="Streli na tekmo", y="Dani goli na tekmo", colour="država")

ggplot(podatki) + aes(tournamentRegionName=tournamentRegionName, teamName=teamName, x=rating, y=passSuccess*100, color=tournamentRegionName) + geom_point(stat="identity") +
  labs(x="Rating", y="Natančnost podaj v %", colour="država") + geom_smooth(aes(group=tournamentRegionName), method="lm", se=FALSE)

ggplot(podatki) + aes(x=teamName, y=possession*100, color=tournamentRegionName) + geom_bar(stat="identity") +
  scale_y_continuous(limits=c(40,66), oob=rescale_none) + labs(x="Ekipa", y="Povprečna posest v %", colour="država")

ggplot(podatki) + aes(x=teamName, y=goal, color=tournamentRegionName) + geom_bar(stat="identity") +
  labs(x="Ekipa", y="Število danih golov v sezoni", colour="država")

ggplot(podatki) + aes(x=teamName, y=rating, color=tournamentRegionName) + geom_bar(stat="identity") + scale_y_continuous(limits=c(6,7.4), oob=rescale_none) +
  labs(x="Ekipa", y="Povprečni rating", colour="država")

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

tm_shape(merge(zemljevid1,
               podatki %>% group_by(tournamentRegionName) %>% summarise(goalPerGame=(sum(goal)/(sum(apps)/2))),
               by.x="SOVEREIGNT", by.y="tournamentRegionName"), xlim=c(-15, 38), ylim=c(30, 75)) +
  tm_polygons("goalPerGame", title="Goli na tekmo") + ggtitle("Goli na tekmo po ligah")

ggplot(podatki, aes(x=tournamentRegionName, teamName=teamName, group_by(tournamentRegionName))) +
  geom_col(aes(y=yellowCard, fill="rumeni kartoni")) +
  geom_col(aes(y=redCard, fill="rdeči kartoni")) + xlab("") + ylab("Vsi kartoni po ligah") +
  ggtitle("Število rumenih in rdečih kartonov") + labs(fill="")

ggplot(podatki) + aes(x=tournamentName, teamName=teamName, y=goal) + labs(x="Liga", y="Goli") +
  geom_bar(stat="identity", fill = "#FF6666")