context("Test formatOccData")

# Create data
n <- 15000 #size of dataset
nyr <- 20 # number of years in data
nSamples <- 100 # set number of dates
nSites <- 50 # set number of sites
set.seed(125)

# Create somes dates
first <- as.Date(strptime("2010/01/01", "%Y/%m/%d"))
last <- as.Date(strptime(paste(2010+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
dt <- last-first
rDates <- first + (runif(nSamples)*dt)

# taxa are set as random letters
taxa <- sample(letters, size = n, TRUE)

# three sites are visited randomly
site <- sample(paste('A', 1:nSites, sep=''), size = n, TRUE)

# the date of visit is selected at random from those created earlier
survey <- sample(rDates, size = n, TRUE)

# set the closure period to be in 2 year bins
closure_period <- ceiling((as.numeric(format(survey,'%Y')) - 2009)/2)

# create survey variable that is not a date and a closure period to match
survey_numbered <- as.integer(as.factor(survey))

replicate <- rep(1, n)

test_that("Test formatOccData", {

  expect_warning(visitData <- formatOccData(taxa = taxa, site = site, survey = survey),
                 '871 out of 15000 observations will be removed as duplicates')

  head_spp_vis <- structure(list(visit = c("A102010-04-141", "A102010-04-221", "A102010-08-291",
                            "A102010-11-041", "A102011-02-091", "A102011-03-091"), a = c(FALSE,
                            FALSE, FALSE, FALSE, FALSE, FALSE), b = c(FALSE, FALSE, FALSE,
                            FALSE, FALSE, FALSE), c = c(FALSE, FALSE, FALSE, FALSE, FALSE,
                            FALSE), d = c(FALSE, TRUE, FALSE, TRUE, FALSE, FALSE), e = c(FALSE,
                            TRUE, FALSE, FALSE, FALSE, FALSE), f = c(FALSE, FALSE, FALSE,
                            FALSE, FALSE, FALSE), g = c(FALSE, FALSE, TRUE, FALSE, FALSE,
                            FALSE), h = c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE), i = c(FALSE,
                            FALSE, FALSE, FALSE, FALSE, FALSE), j = c(FALSE, FALSE, FALSE,
                            FALSE, FALSE, FALSE), k = c(FALSE, FALSE, FALSE, FALSE, FALSE,
                            FALSE), l = c(TRUE, FALSE, FALSE, FALSE, FALSE, TRUE), m = c(FALSE,
                            FALSE, FALSE, FALSE, FALSE, FALSE), n = c(FALSE, TRUE, TRUE,
                            FALSE, FALSE, FALSE), o = c(TRUE, FALSE, FALSE, FALSE, FALSE,
                            FALSE), p = c(FALSE, FALSE, FALSE, FALSE, FALSE, TRUE), q = c(FALSE,
                            TRUE, FALSE, FALSE, FALSE, FALSE), r = c(TRUE, FALSE, FALSE,
                            FALSE, FALSE, FALSE), s = c(FALSE, FALSE, FALSE, TRUE, TRUE,
                            FALSE), t = c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE), u = c(FALSE,
                            FALSE, FALSE, FALSE, FALSE, FALSE), v = c(FALSE, FALSE, FALSE,
                            FALSE, FALSE, FALSE), w = c(TRUE, FALSE, FALSE, FALSE, FALSE,
                            FALSE), x = c(FALSE, TRUE, FALSE, FALSE, FALSE, FALSE), y = c(FALSE,
                            FALSE, FALSE, FALSE, FALSE, FALSE), z = c(TRUE, FALSE, FALSE,
                            FALSE, FALSE, FALSE)), .Names = c("visit", "a", "b", "c", "d",
                            "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q",
                            "r", "s", "t", "u", "v", "w", "x", "y", "z"), row.names = c(NA,
                            6L), class = "data.frame")

 head_occDetdata <- structure(list(visit = c("A102010-04-141", "A102010-04-221",
                                             "A102010-08-291", "A102010-11-041",
                                             "A102011-02-091", "A102011-03-091"),
                                   site = c("A10", "A10", "A10", "A10", "A10",
                                            "A10"),
                                   L = c(5L, 5L, 2L, 2L, 1L, 2L),
                                   TP = c(2010, 2010, 2010, 2010, 2011, 2011)),
                              row.names = c(1L, 6L, 11L, 13L, 15L, 16L),
                              class = "data.frame")

  expect_identical(head(visitData$spp_vis), head_spp_vis)
  expect_identical(head(visitData$occDetdata), head_occDetdata)

})

test_that("Test formatOccData errors", {

  expect_error(visitData <- formatOccData(taxa = head(taxa), site = site, survey = survey, closure_period = closure_period, replicate = replicate),
               'The following arguements are not of equal length: taxa, site, survey, closure_period, replicate')
  expect_error(visitData <- formatOccData(taxa = taxa, site = head(site), survey = survey, closure_period = closure_period, replicate = replicate),
               'The following arguements are not of equal length: taxa, site, survey, closure_period, replicate')
  expect_error(visitData <- formatOccData(taxa = taxa, site = site, survey = head(survey), closure_period = closure_period, replicate = replicate),
               'The following arguements are not of equal length: taxa, site, survey, closure_period, replicate')
  expect_error(visitData <- formatOccData(taxa = taxa, site = site, survey = survey, closure_period=head(closure_period), replicate = replicate),
               'The following arguements are not of equal length: taxa, site, survey, closure_period, replicate')
  expect_error(visitData <- formatOccData(taxa = taxa, site = site, survey = survey, closure_period=closure_period, replicate = head(replicate)),
               'The following arguements are not of equal length: taxa, site, survey, closure_period, replicate')

})

test_that("Test formatOccData date requirement errors", {

  expect_warning(visitData <- formatOccData(taxa = taxa, site = site, survey = survey, closure_period = closure_period),
                 '871 out of 15000 observations will be removed as duplicates')
  expect_error(suppressWarnings(visitData <- formatOccData(taxa = taxa, site = site, survey = survey_numbered)),
               'survey must be a date if closure_period not supplied')
  expect_error(suppressWarnings(visitData <- formatOccData(taxa =taxa, site = site, survey = survey_numbered, includeJDay = TRUE, closure_period = closure_period)),
               'survey must be a date if Julian Date is to be included')
})

test_that("Test formatOccData specified closure period", {

  expect_warning(visitData <- formatOccData(taxa = taxa, site = site, survey = survey, closure_period = closure_period),
                 '871 out of 15000 observations will be removed as duplicates')

  head_occDetdata_cp <- structure(list(visit = c("A102010-04-141", "A102010-04-221",
                                                 "A102010-08-291", "A102010-11-041",
                                                 "A102011-02-091", "A102011-03-091"),
                                       site = c("A10", "A10", "A10", "A10", "A10", "A10"),
                                       L = c(5L, 5L, 2L, 2L, 1L, 2L),
                                       TP = c(1L, 1L, 1L, 1L, 1L, 1L)),
                                  row.names = c(1L, 6L, 11L, 13L, 15L, 16L),
                                  class = "data.frame")

  expect_identical(head(visitData$occDetdata), head_occDetdata_cp)

})


library(tidyverse)

d = read_csv('data/02_TVJ_pretest/data_raw.csv') %>%
  mutate(response = ifelse(response == "TRUE", 1, 0))

d = d[-which(d$comments == "Test run by MF"),]

d_summary = d %>% group_by(trigger, condition, question) %>%
  summarize(mean_true = mean(response)) %>% arrange(condition)

d_summary_id = d %>% group_by(submission_id, trigger, condition) %>%
  summarize(mean_true = mean(response)) %>% arrange(submission_id) %>%
  filter(condition == "implicature")

d_summary_id %>% filter(trigger != "number") %>%
  group_by(submission_id) %>%
  summarize(mean_true = mean(mean_true)) %>%
  ggplot(aes(x = mean_true)) + geom_histogram()


# 4. faza: Analiza podatkov

# Uvozimo funkcijo za uvoz spletne strani.
source("lib/xml.r")

# # Preberemo spletno stran v razpredelnico.
# cat("Uvažam spletno stran...\n")
# tabela <- preuredi(uvozi.obcine(), obcine)
#
# # Narišemo graf v datoteko PDF.
# cat("Rišem graf...\n")
# pdf("slike/naselja.pdf", width=6, height=4)
# plot(tabela[[1]], tabela[[4]],
#      main = "Število naselij glede na površino občine",
#      xlab = "Površina (km^2)",
#      ylab = "Št. naselij")
# dev.off()

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

# # CLUSTERING
#
# data <- CHI
# data$Team <- NULL
# data$Pos <- NULL
# data$Naziv <- NULL
# data$Coutry <- NULL
# data$Birth.City <- NULL
# data$FO. <- NULL
# data$TOI.GP <- NULL
#
# data1 <- scale(data)
#
# #Narišemo grafe
#
# rezultati <- kmeans(data1, centers = 3)
# center <- rezultati$centers
# skupina <- rezultati$cluster
# barve <- c("red", "green", "blue")
#
# pdf("slike/clustering_1.pdf")
#
#
# plot(data[,"P"],data[,"X..."], col = barve[skupina],
#      xlab = "Število točk", ylab = "+/-",
#      main = "Razvrščanje - Odvisnost števila točk in +/-")
#
# # plot(iris2[c("G", "X...")], col = rezultati$cluster)
# # points(rezultati$centers[,c("G", "X...")], col = 1:3,
# #        pch = 8, cex=2)
#
# dev.off()
#
#
# pdf("slike/clustering_2.pdf")
# plot(data[,"G"],data[,"S"], col = barve[skupina],
#      xlab = "Število zadetkov", ylab = "Število strelov",
#      main = "Razvrščanje - Odvisnost števila golov in število strelov")
# dev.off()

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

# Napovedovanje

pdf("slike/place.pdf")

leto <- salary$YEAR
place <- salary$AVERAGE.SALARY/1000000

plot(leto, place, xlab = "Leto", ylab = "Plače v mio $", main = "Linearna, kvadratna in gam metoda")

legend(2000, 1, c("Linerana metoda", "Gam metoda"), lty=c(1,1),
       col = c("blue", "green"))

#Napišemo funkcijo za linearno rast

linearna <- lm(place ~ leto)
abline(linearna, col="blue")

#Preverimo če so plače kvadratna funkcija

kvadratna <- lm(place ~ I(leto^2) + leto)
# curve(predict(kvadratna, data.frame(leto=x)), add = TRUE, col = "red")

#Loess model za primerjavo (model loess uporablja lokalno prilagajanje)

loess <- loess(place ~ leto)

# Gam model
library(mgcv)
gam <- gam(place~s(leto))
curve(predict(gam, data.frame(leto=x)), add = TRUE, col = "green")
#Pogledamo ostanke pri modelih. Tisti, ki ima manjši ostanek je bolj natančen

vsota.kvadratov <- sapply(list(linearna, kvadratna, loess, gam), function(x) sum(x$residuals^2))
# najmanjša vrednost je z metodo gam - 0.44273517 0.44272328 0.26843681 0.06716553

dev.off()
################################

#Narisali bomo napoved za rast plač do leta 2030 po modelpo treh modelih - linearni, kvadratni in gam

pdf("slike/napoved.pdf")

plot(salary$YEAR, place, xlim = c(1989, 2040), ylim = c(0, 10),
     xlab = "Leto", ylab = "Plače v mio $",
     main = "Napovedana rast plač igralcev lige MLB")
abline(h = 3.818923,col = "black", lwd = 1.5, lty = 1)
abline(h = 5.98,col = "black", lwd = 1.5, lty = 1)
abline(h = 7.3,col = "black", lwd = 1.5, lty = 1)

# Presečišča

points(2030, 5.98,  col = "black", pch = 21)
points(2030, 7.3,  col = "black", pch = 21)

# V presečiščih potegnemo navpične črte

abline(v=2014, col = "magenta", lty = 1)
abline(v=2030, col = "darkblue", lty = 1)
abline(v=2040, col = "lightblue2", lty = 1)

napoved <- function(x,model){predict(model, data.frame(leto=x))}

curve(napoved(x, linearna), add= TRUE, lwd = 1.5, col = "blue")
# curve(napoved(x, kvadratna), add = TRUE, lwd = 1.5, col = "red")
curve(napoved(x, gam), add=TRUE, col="green")
#curve(napoved(x, loess), add = TRUE, lwd = 1.5, col = "black")

# Legenda
legend(2015, 3, c("Linearna", "Gam"),
       lty=c(1,1), col = c("blue", "green"))

dev.off()

#################################################################################################
# Hierarhično razvrščanje

pdf("slike/hierarhija.pdf")

X <- scale(as.matrix(ekipe[1:18]))
t <- hclust(dist(X), method = "ward.D")

plot(t, hang=-1, cex=0.4, main = "Skupine klubov")

legend("topright",
       c("Skupina 1", "Skupina 2","Skupina 3"),
       lty=c(1,1,1), col = c("blue","green","red"))

rect.hclust(t,k=3,border=c("blue","red","green"))

p1 <- cutree(t, k=3)

dev.off()

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

# Poiskati želim najboljše igralce v klubu po vseh statističnih spremenljivkah.

CHI$TOI.GP <- NULL
normaliziran <- scale(as.matrix(CHI[c(6:18)]))
matrikarazdalj <- dist(normaliziran)
razdelitev <- hclust(matrikarazdalj, method = "complete")

pdf("slike/najigralci.pdf")
plot(razdelitev, hang=-1, cex=0.6, main = "Uspešnost igralcev ekipe Chicago Blackhawks")
rect.hclust(razdelitev,k = 4,border="orange")
dev.off()

p <- cutree(razdelitev, k=4)
barve=c("red", "green", "blue","cyan")
table(p)
barve

pdf("slike/najigralci1.pdf")
pairs(normaliziran, col = barve[p])
dev.off()

# Graf prikazuje položaje osamelcev v odvisnosti od ostalih igralcev.

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

# Metoda enojnega povezovanja

razdelitev1 <- hclust(matrikarazdalj, method = "single")

pdf("slike/chicago.pdf")
plot(razdelitev1, hang=-1, cex=0.6, main = "Uspešnost igralcev z metodo enojnega povezovanja")
rect.hclust(razdelitev1,k=4,border="red")
dev.off()


#' Overall nucleotides frequency
#'
#' Calculate the overall nucleotides frequency composition
#'
#' @param x a list of KZsqns objects.
#' @return a n-by-4 numeric matrix, where n is the length of list x
#'
#' @examples
#' data(CodonTable0)
#' x = vector('list', 5) # Creating an empty list of length 5
#'
#' for(i in 1:5){
#' x[[i]] = CodonTable0[sample(1:64, 10*i, TRUE),1]
#' attr(x[[i]], 'class') = 'KZsqns'
#' }
#'
#' cat(base_freq(x))
#' @export

base_freq<- function(x){
  if(!is.list(x)){
    cat("Just one perhap very long sequence?\n")
    x = list(x)
  }

  ans = matrix(0, length(x), 4)
  for(i in 1:length(x)){
    if(class(x[[i]])!='KZsqns') warning("KZsqns objects are expected")
    freq_table = table(strsplit(paste0(paste0(x[[i]], collapse = ''),'ATGC', sep=''),''))
    ans[i,] = (freq_table-rep(1,4))/length(x[[i]])/3
  }

  colnames(ans) <- c('A', 'C', 'G', 'T')
  rownames(ans) <- paste0('s_', 1:length(x), sep='')
  return(ans)
}


require(maptools)
require(sp)
require(raster)
require(rgeos)

# this little script fixes a small problem with the origin of the RAD data being different than the origin of the downscaled outputs.  this is creating an issue where I
#  cannot perform any calculation of the 2 maps until the origins match.

l <- list.files("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/outputs/girr_radiation/", pattern=".tif", full.names=T)
# now stack that list of files
rad.monthly <- stack(l)

# this is the template map used to rasterize the data to a new origin
out_template <- raster("/Data/Base_Data/ALFRESCO_formatted/ALFRESCO_Master_Dataset/ALFRESCO_Model_Input_Datasets/AK_CAN_Inputs/Climate/cru_TS31/historical/pr/pr_total_mm_alf_cru_TS31_01_1901.tif")

for (i in 1:nlayers(rad.monthly)){
	print(i)
	rad.monthly.current <- subset(rad.monthly, i , drop=T)
	xyz <- cbind(coordinates(rad.monthly.current), getValues(rad.monthly.current))
	pts <- SpatialPoints(xyz[,1:2])
	pts.spdf <- SpatialPointsDataFrame(pts, as.data.frame(xyz), match.ID=TRUE,proj4string=projection(out_template))
	rasterize(pts.spdf, out_template, field=pts.spdf$V3, fun=mean,filename=paste("/workspace/UA/malindgren/projects/iem/PHASE2_DATA/RSDS_working/September2012_finalRuns/outputs/girr_radiation/version2/",rad.monthly@layernames[i],".tif",sep=""), overwrite=TRUE)
}


library(data.table)
library(ggplot2)
library(RColorBrewer)
library(sf)

source('../../functions.r')
source('../../parameters.r')

spplist  <- fread('../../input-data/species-list.csv')
setkey(spplist, code)
nspp <- nrow(spplist)

load('mcmc-results.rdata')
mcsumm <- readRDS('mcmc-results-summary.rds')

grid <- read_sf('../../input-data/southern-hemisphere-5-degree.shp')
world <- read_sf('../../input-data/world.shp')

## * APF by species

mcsel <- mcmc[variable %in% mc_attributes[role == 'month0_spatial1' & vartype == 'apf_t', variable]]
mcsel <- merge(mcsel, mc_attributes, by = 'variable', all.x=T, all.y=F)
apf_sp <- mcsel[, .(value = sum(value)), .(species, grid_id, sample)][
  , .(mean     = mean(value),
      median   = median(value),
      sd       = sd(value),
      lcl      = quantile(value, 0.025, names=F),
      ucl      = quantile(value, 0.975, names=F),
      nsamples = .N), .(code = species, grid_id)]

apf_sp <- apf_sp[spplist[base_species == T], on = 'code'][, .(common_name = upper1st(common_name), code, grid_id, mean , sd, lcl, ucl)]
apf_sp

spp <- spplist[base_species == T]
for (i in 1:nrow(spp)) {
    apf1 <- apf_sp[code == spp[i, code]]
    sp_apf <- apf1[match(grid$GRID_ID, grid_id), mean]
    sp_apf[sp_apf == 0] <- NA
    grid[[spp[i, code]]] <- sp_apf
}

grid2 <- sf::st_transform(grid, "+proj=laea +y_0=0 +lon_0=179 +lat_0=-90 +ellps=WGS84 +no_defs")
world2 <- sf::st_transform(world, "+proj=laea +y_0=0 +lon_0=179 +lat_0=-90 +ellps=WGS84 +no_defs")
w2 <- st_as_sf(raster::crop(as(world, 'Spatial'), raster::extent(as(grid, 'Spatial'))))
w2 <- sf::st_transform(w2, "+proj=laea +y_0=0 +lon_0=179 +lat_0=-90 +ellps=WGS84 +no_defs")

sp='DQS'
for (sp in spp$code) {
    cat(sp, '\n')
    grid2$sp <- grid2[[sp]]
    g <- ggplot() +
        geom_sf(data = grid2, aes(fill = sp), colour = '#CCCCCC', size = 0.1, na.rm=T) +
        geom_sf(data = w2, fill = '#AAAAAA', colour = NA, size = 0.1, na.rm=T) +
        scale_fill_gradientn(name = 'APF', colours = brewer.pal(9, 'BuPu'), na.value=NA, limits = c(0, NA)) +
        theme_void() +
        theme(legend.position=c(0.95, 0.15))
    ggsave(sprintf('assets/apf-map-%s.png', sp), width = 7, height = 7)
}


library(readr)
library(dplyr)
library(ggplot2)
library("cowplot")

user <- read_csv('Users.csv')
glimpse(user)

table(user$ group)

library(rlang)
myplot <- function(mydf, myxcol, myycol, ymin=0,ymax=1) {
   ggplot2::ggplot(data = mydf, aes(x=reorder({{ myxcol }},
      {{ myycol }}), y= {{ myycol }},col  = factor(group))) +
        geom_jitter(height = 0.1, width = 0.5,alpha = .08, shape = 16,aes(colour = factor(group)))+
        geom_violin(trim=TRUE,alpha=0.35, position = position_dodge(width = 1),colour=NA,aes( fill  = factor(group)))+
    geom_boxplot(notch = FALSE,width=.4,  outlier.size = -1, lwd=.6,outlier.shape = NA,fill = NA,
                 col=c('steelblue4','deeppink4'),lty=1)+ #,'',''
    ylim(ymin,ymax)+
    scale_x_discrete(limits=c('NP',"CP"),label=c('Control', 'Experiment' ))+ coord_flip()+
         stat_summary(fun.y=mean, geom="point", shape=18, size=4)+# color=c('orange4','darkolivegreen4','purple4','forestgreen'), fill=c('orange4','darkolivegreen4','purple4','forestgreen')) +
#     scale_colour_manual(limits=c('TR','AI',"NR", "SR",'SAI'),values = aes(colour = factor(Condition)))#c('darkkhaki','deeppink4','snow4','blue4','orchid4')) +
#     scale_fill_manual(limits=c('TR','AI',"NR", "SR",'SAI'),values = c('olivedrab4','maroon4','navajowhite4','steelblue4','violetred4')) +
#     scale_linetype_manual(limits=c('AI',"NR", "SR",'SAI'),values = c(1,1,1,1)) +
    theme(plot.title = element_text(hjust = 0.5),plot.margin = unit(c(0.1, 0.1, 0, 0), "cm"),axis.title.x=element_blank(), axis.title.y=element_blank(),
    panel.grid=element_line(colour="lightgrey", size = (.05))  ,panel.background =element_blank() ,legend.position="none")

}

bx1=myplot(user, group, words,0,max(user$words))
bx1

pdf("words.pdf", width=4, height=3)
bx1
dev.off()

bx1=myplot(user, group, likeRate   ,0,max(user$likeRate   ))
bx1

pdf("likeRate.pdf", width=4, height=3)
bx1
dev.off()

bx1=myplot(user, group, Decision      ,min(user$Decision      ),max(user$Decision      ))
bx1

pdf("Decision.pdf", width=4, height=3)
bx1
dev.off()

bx1=myplot(user, group, Confidence       ,min(user$Confidence       ),max(user$Confidence       ))
bx1

pdf("Confidence.pdf", width=4, height=3)
bx1
dev.off()

1-Submission/Evaluation_Fig4_Comparing length and like.r