#!/usr/bin/env Rscript
#
#  adonis.r - R slave for two-way permanova analysis with R package vegan
#
#  Version 1.0.0 (July, 15, 2016)
#
#  Copyright (c) 2016-- Lela Andrews
#
#  This software is provided 'as-is', without any express or implied
#  warranty. In no event will the authors be held liable for any damages
#  arising from the use of this software.
#
#  Permission is granted to anyone to use this software for any purpose,
#  including commercial applications, and to alter it and redistribute it
#  freely, subject to the following restrictions:
#
#  1. The origin of this software must not be misrepresented; you must not
#     claim that you wrote the original software. If you use this software
#     in a product, an acknowledgment in the product documentation would be
#     appreciated but is not required.
#  2. Altered source versions must be plainly marked as such, and must not be
#     misrepresented as being the original software.
#  3. This notice may not be removed or altered from any source distribution.
#

## Recieve input files from bash
args <- commandArgs(TRUE)
map=(args[1])
dmfile=(args[2])
factor1=(args[3])
factor2=(args[4])
f1temp=(args[5])
f2temp=(args[6])
outdir=(args[7])
perms0=(args[8])
perms <- as.integer(perms0)

## Load libraries
library(vegan)

## Read in data
mapfile <- read.csv(map, sep="\t", header=TRUE)
dm <- read.csv(dmfile, sep="\t", header=TRUE)
f1 <- mapfile[,factor1]
f2 <- mapfile[,factor2]

## Run permanova and print to screen
pm <- adonis(formula = dm ~ f1 * f2, permutations = perms)
pm

## End
q()


#' memuse Arithmetic
#'
#' Binary arithmetic operations for \code{memuse} objects.
#'
#' Simple arithmetic reductions.
#'
#' @param x
#' A \code{memuse} object.
#' @param ...
#' Additional arguments
#' @param na.rm
#' Whether \code{NA}'s should be ignored.
#'
#' @return
#' Returns a \code{memuse} class object.
#'
#' @examples
#' \dontrun{
#' x = mu(2000)
#' y = mu(5000)
#'
#' sum(x, y)
#'
#' ### Mixing numeric and memuse objects will work, but the first one must be a
#' ### memuse object.
#' sum(mu(10), 10) # This will work
#' sum(10, mu(10)) # This will not
#' }
#'
#' @seealso \code{ \link{Constructor} \link{memuse-class} }
#' @keywords Methods
#' @export
setMethod("sum", signature(x="memuse"),
  function(x, ..., na.rm=FALSE)
  {
    ret <- mu.size(x, as.is=FALSE)

    other <- list(...)

    # checking type of inputs
    typecheck <- sapply(other, sumargcheck)

    if (length(other) > 0)
    {
      other <- sum(sapply(other, vectorizedsum))
      ret <- ret + other
    }

    internal.mu(ret, unit.prefix=mu.prefix(x), unit.names=mu.names(x))
  }
)

sumargcheck = function(i)
{
  if ( !is.memuse(i) && !(is.numeric(i) && is.vector(i)) )
    stop("method 'sum' can only work with combinations of memuse and vector objects")
}

vectorizedsum = function(i)
{
  if (is.memuse(i))
    mu.size(i, as.is=FALSE)
  else
    sum(i)
}


context("Remove equivalent columns")

data(iris)

iris$Sepal.Length2 <- 3 * iris$Sepal.Length + 3
remove_equiv_columns(iris)
expect_true(equiv(iris[-1], remove_equiv_columns(iris, "Sepal.Length2")))


library(tidyverse)
library(reshape2)
library(RCurl)
library(ggthemes)

federal_git = getURL('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-02-12/energy_spending.csv')
fed_df = read_csv(federal_git)

names(fed_df)

fed_df$department[237] == "High-Energy Physics*"
fed_df$year
fed_df$energy_spending

spend_plot = ggplot(fed_df , aes(x= year, y = energy_spending, colour = department))+
			geom_point()

spend_plot


require(plyr)
require(stringr)

score.sentiment = function(sentences, pos.words, neg.words, .progress='none')
{

  # we got a vector of sentences. plyr will handle a list or a vector as an "l" for us
  # we want a simple array of scores back, so we use "l" + "a" + "ply" = laply:
  scores = laply(sentences, function(sentence, pos.words, neg.words) {

    # clean up sentences with R's regex-driven global substitute, gsub():
    sentence = gsub('[[:punct:]]', '', sentence)
    sentence = gsub('[[:cntrl:]]', '', sentence)
    sentence = gsub('\\d+', '', sentence)
    # and convert to lower case:
    sentence = tolower(sentence)

    # split into words. str_split is in the stringr package
    word.list = str_split(sentence, '\\s+')
    # sometimes a list() is one level of hierarchy too much
    words = unlist(word.list)

    # compare our words to the dictionaries of positive & negative terms

    neg.matches = match(words, neg.words)
    pos.matches = match(words, pos.words)

    # match() returns the position of the matched term or NA
    # we just want a TRUE/FALSE:
    pos.matches = !is.na(pos.matches)
    neg.matches = !is.na(neg.matches)

    # and conveniently enough, TRUE/FALSE will be treated as 1/0 by sum():
    score = sum(pos.matches) - sum(neg.matches)

    return(score)
  }, pos.words, neg.words, .progress=.progress )

  scores.df = data.frame(score=scores, text=sentences)
  return(scores.df)
}

RedRabbit ES-R/R - ETL  Score - ES endpoin/Sentiment-classification/not tested score.sentiment.r


  applySum = function( f, method="fast", newnames=NULL ) {
    cnames= c("id", "x", "w" )

    if (is.null( newnames )) newnames=names(f)

    if( is.vector(f) ) {

      out = as.data.frame( xtabs( ~ f) , stringsAsFactors=FALSE  )

    } else {

      # data.frame metod

      nv = ncol(f)
      names(f) = cnames[1:nv]

      if( nv==3 ) f$x = f$x* f$w

      o = which( is.finite( f$x) )
      if ( length(o) == 0 ) return( "No data?")
      f = f[o,]

      if (method=="slow") {
        r = by( f, f$id, with, sum( x, na.rm=TRUE ))
        out = data.frame( id=names(r), x=as.numeric(as.vector(r)) , stringsAsFactors=FALSE )

      } else if (method=="fast") {

        f$id = as.factor( f$id )
        l0 = 1 / median( f$x, na.rm=TRUE ) # a scaling factor to help avoid overflow errors
        f$x = as.numeric( f$x * l0)
        out = as.data.frame( xtabs( f$x ~ f$id, na.action=na.omit) / l0, stringsAsFactors=FALSE )

      } else if (method=="compact_but_slow") {

        rowindex = 1:nrow(f)
        out = aggregate( rowindex ~ id, f, function(i) sum( f$x[i], na.rm=TRUE ), na.action=na.omit ) #

      }
    }

    names(out) = newnames[1:2]
    return( out )
  }


#######DESCRIPTION###############################
#uses stage-discharge fitted rating curves to produce 0-15 day lead
#forecasts of stage
#requires fitted rating curves from stage_ratingcurvefit.r
#observed stage values
#################################################
##load libraries
library(tools)
library(ncdf4)
library(dplyr)
library(data.table)
library(ggplot2)
library(minpack.lm)
library(hydroGOF)
library(R.utils)
library(scales)
library(RColorBrewer)
library(foreach)
library(doParallel)

##user inputs
fcst_start_date = '2015-06-15'
fcst_end_date = '2015-10-31'
fcst_leads = 0:15
fcst_sta_ids = c('007-mgd4ptn', '002-MGD4PTN', '006-mgd4ptn', '005-mgd4ptn', '004-MGD4PTN', '029-mgd5ptn', '024-MGD4PTN', '023-mgd4ptn', '022-mgd4ptn', '025-mgd4ptn', '019-mgd4ptn', '001-MGD4PTN', '015-mgd4ptn')
dir_dat = '/Volumes/gonggong/flood forecasting/data/'
dir_ref = '/Volumes/gonggong/flood forecasting/data/reference tables/'
dir_fcst = '/Volumes/gonggong/flood forecasting/data/'
run_name = 'bagmati-kosi'
npts_thresh = 20
nse_thresh = 0.1

##read in data
stage_dat = readRDS(paste0(dir_dat, 'stage.rda'))
rating_curve_tbl = readRDS(paste0(dir_dat, 'rating_curve_all-bagmati-kosi.rda'))
stage_weight_tbl = readRDS(file.path(dir_ref, 'stage_weight_tbl.rda'))

##process data
stage_dat_day = stage_dat %>% dplyr::filter(hour %in% c(6:18)) %>% dplyr::mutate(hour_min = hour - 12) %>% group_by(year, month, day, sta_id) %>% dplyr::slice(which.min(hour_min)) %>% ungroup() %>% dplyr::select(date, sta_id, basin, stage) %>% dplyr::mutate(date = as.Date(date)) %>% data.table()
rating_curve_tbl = rating_curve_tbl %>% dplyr::filter(nse >= nse_thresh, npts > npts_thresh)
rating_curve_opt_tbl = rating_curve_tbl %>% group_by(sta_id) %>% dplyr::slice(which.max(nse)) %>% data.table()

fcst_dates = seq(from = as.Date(fcst_start_date), to = as.Date(fcst_end_date), by = 'day')
fcst_tbl = data.table(sta_id = rep(fcst_sta_ids, each = length(fcst_dates) * length(fcst_leads)), fcst_date = fcst_dates, fcst_lead = rep(fcst_leads, each = length(fcst_dates)))

##forecast
cl = makeCluster(7)
registerDoParallel(cl)
Q_fcst_ls = foreach(j = 1:nrow(fcst_tbl)) %dopar% {
	fcst_lead_temp = fcst_tbl$fcst_lead[j]
	fcst_date_temp = fcst_tbl$fcst_date[j]
	fcst_sta_id_temp = fcst_tbl$sta_id[j]
	rating_curve_fcst_tbl = rating_curve_tbl %>% dplyr::filter(lag >= fcst_lead_temp, sta_id_ds == fcst_sta_id_temp) %>% group_by(sta_id) %>% data.table()
	sta_id_set = stage_weight_tbl %>% dplyr::filter(sta_id == fcst_sta_id_temp) %>% dplyr::select(sta_id_us)

	Q_fcst = NULL
	for(i in fcst_lead_temp:15){
		Q_fcst_temp = stage_dat_day %>% dplyr::filter(sta_id %in% sta_id_set$sta_id_us, date == (fcst_date_temp - as.difftime(i, unit = 'days'))) %>% dplyr::mutate(lag = i) %>% data.table()
		Q_fcst_temp = Q_fcst_temp %>% left_join(rating_curve_fcst_tbl)
		Q_fcst = bind_rows(Q_fcst, Q_fcst_temp)
	}

	Q_fcst = Q_fcst %>% dplyr::mutate(Q_fcst_uw = C * (stage + a)^n, wt = 1 / err) %>% dplyr::filter(!is.na(Q_fcst_uw)) %>% dplyr::mutate(Q_fcst = Q_fcst_uw * wt)
	Q_fcst = Q_fcst %>% group_by(sta_id) %>% dplyr::slice(which.max(nse)) %>% ungroup()
	Q_fcst$fcst_date = fcst_date_temp
	Q_fcst$fcst_lead = fcst_lead_temp
	Q_fcst
	# Q_fcst_best = sum(Q_fcst$Q_fcst) / sum(Q_fcst$wt)
	# Q_fcst_temp = data.table(sta_id = fcst_sta_id_temp, Q_fcst = Q_fcst_best, fcst_lead = fcst_lead_temp, fcst_date = fcst_date_temp)

	# Q_fcst_tbl = bind_rows(Q_fcst_tbl, Q_fcst_temp)
}
stopCluster(cl)
Q_fcst_diag_tbl = do.call('bind_rows', Q_fcst_ls)

Q_stage_fcst_tbl = Q_fcst_tbl %>% left_join(rating_curve_opt_tbl) %>% dplyr::mutate(stage_fcst = (Q_fcst / C) ^ (1 / n) - a)
#save data
saveRDS(Q_stage_fcst_tbl, paste0(dir_fcst, run_name, '_Q_stage_fcst.rda'))


# Copyright: Robert P Herbig, 2011

# Interpreter at http://ideone.com/

rows <- 3
cols <- 6
start <- matrix( c(0,1,2,3,4,5, 6,7,8,9,10,11, 12,13,14,15,16,17), nrow=rows, ncol=cols, byrow=TRUE )
print(start)
end <- start
for(i in 1:rows) {
  for(j in 1:cols) {
    if(start[i,j]==0) {
      end[i,] <- 0
      end[,j] <- 0
    }
  }
}
print(end)


# From http://menugget.blogspot.com/2011/08/adding-scale-to-image-plot.html#more
#This function creates a color scale for use with e.g. the image()
#function. Input parameters should be consistent with those
#used in the corresponding image plot. The "horiz" argument
#defines whether the scale is horizonal(=TRUE) or vertical(=FALSE).
#Depending on the orientation, x- or y-limits may be defined that
#are different from the z-limits and will reduce the range of
#colors displayed.

image.scale <- function(z, zlim, col = heat.colors(12),
breaks, horiz=TRUE, ylim=NULL, xlim=NULL, ...){
 if(!missing(breaks)){
  if(length(breaks) != (length(col)+1)){stop("must have one more break than colour")}
 }
 if(missing(breaks) & !missing(zlim)){
  breaks <- seq(zlim[1], zlim[2], length.out=(length(col)+1))
 }
 if(missing(breaks) & missing(zlim)){
  zlim <- range(z, na.rm=TRUE)
  zlim[2] <- zlim[2]+c(zlim[2]-zlim[1])*(1E-3)#adds a bit to the range in both directions
  zlim[1] <- zlim[1]-c(zlim[2]-zlim[1])*(1E-3)
  breaks <- seq(zlim[1], zlim[2], length.out=(length(col)+1))
 }
 poly <- vector(mode="list", length(col))
 for(i in seq(poly)){
  poly[[i]] <- c(breaks[i], breaks[i+1], breaks[i+1], breaks[i])
 }
 xaxt <- ifelse(horiz, "s", "n")
 yaxt <- ifelse(horiz, "n", "s")
 if(horiz){YLIM<-c(0,1); XLIM<-range(breaks)}
 if(!horiz){YLIM<-range(breaks); XLIM<-c(0,1)}
 if(missing(xlim)) xlim=XLIM
 if(missing(ylim)) ylim=YLIM
 plot(1,1,t="n",ylim=ylim, xlim=xlim, xaxt=xaxt, yaxt=yaxt, xaxs="i", yaxs="i", ...)
 for(i in seq(poly)){
  if(horiz){
   polygon(poly[[i]], c(0,0,1,1), col=col[i], border=NA)
  }
  if(!horiz){
   polygon(c(0,0,1,1), poly[[i]], col=col[i], border=NA)
  }
 }
}


setwd("C:/Github_folder/scVEGs")
source("scVEGs.r")
data <- read.delim('data_GSE65525.txt', header = TRUE, stringsAsFactors = TRUE)
rownames(data) <- data[, 1]
data <- data[, -1]
pVal <- 0.01
pFlag <- 1
species <- 'mmu'

cellSum <- apply(data, 2, sum)
scaleNum <- mean(cellSum)/cellSum
scaleFactor <- t(kronecker( matrix(1, 1, dim(data)[1]), scaleNum))
normData <- scaleFactor * data
outputName <- 'result_GSE65525'
sig <- scVEGs(normData, pVal, pFlag, species, outputName)

write.table(sig, file = 'result_GSE65525_sig.txt', append = FALSE, quote = FALSE,
            sep = "\t", eol = "\n", na = "NA", dec = ".", row.names = TRUE,
            col.names = TRUE, qmethod = c("escape", "double"))


# Calculates the S3 cost over a time period of X months (note - costs rise as the volume of data increases month by month)
s3CostByMonth <- function(eventsPerMonth, runsPerDay, edgeLocations, numberOfMonths){
	# Create the vector of monthly s3 costs, which the function will return
	s3CostByMonth <- vector()

	# Before Snowplow starts, there is no Snowplow dqta in S3
	gigabytesAlreadyInS3 <- 0

	# Calculate the s3 cost for each month, and save the monthly cost in the vector
	for(i in 1:numberOfMonths){
		ithMonth <- s3CostPerMonth(gigabytesAlreadyInS3, eventsPerMonth, runsPerDay, edgeLocations)
		gigabytesAlreadyInS3 <- ithMonth[2]
		ithMonthCost <- ithMonth[1]
		s3CostByMonth <- append(s3CostByMonth, ithMonthCost)
	}

	# Return the vector
	s3CostByMonth
}

# Calculate the S3 cost per month AND volume of data stored in S3 at the end of the month
# (We need the volume of data stored at the month end when we calculate the monthyl costs over time)
s3CostPerMonth <- function(gigabytesSnowplowDataAlreadyInS3, eventsThisMonth, runsPerDay, edgeLocations){
	cfLogs <- cfLogsGenerated(eventsThisMonth, edgeLocations)
	snplowEventFiles <- snowplowEventFilesGenerated(eventsThisMonth, runsPerDay)

	newFilesGenerated <- cfLogs + snplowEventFiles

	# Note: for each file (cfLog and snowplow event file), there is 3 POST / COPY requests and 1 GET request
	putCopyListRequests <- newFilesGenerated[2] * 3
	getRequests <- newFilesGenerated[2]

	gigabytesDataAtMonthEnd <- gigabytesSnowplowDataAlreadyInS3 + newFilesGenerated[1]
	s3Cost <- s3CostPerMonthRaw(gigabytesDataAtMonthEnd, putCopyListRequests, getRequests)

	c(s3Cost, gigabytesDataAtMonthEnd)
}

# Calculate the S3 cost per month, based on the volume of data stored, the number of PUT / COPY / POST /  LIST requests and the number of GET requests
s3CostPerMonthRaw <- function(gigabytesStored, putCopyListRequests, getRequests){
	storageCostPerGigabyte <- 0.095
	putCopyPostListRequestPricePerThousandRequests <- 0.005
	getRequestPricePerTenThousandRequests <- 0.004

	storageCost <- storageCostPerGigabyte * gigabytesStored
	requestCost <- putCopyPostListRequestPricePerThousandRequests / 1000 * putCopyListRequests +
					getRequestPricePerTenThousandRequests / 10000 * getRequests

	# Return the total cost
	storageCost + requestCost
}


library(bio3d)
args = commandArgs(trailingOnly=TRUE)
pdb <- read.pdb( args[1] )
modes <- nma(pdb)
dim = strtoi( args[2] )
#print( modes )
#dput( modes$modes[,args[2] ], file=args[3] )
dput( modes$modes[,dim] )


library(dHRUM)
nHrus <- 1
Areas <- runif(nHrus,min = 1,max  = 10)
IdsHrus <- paste0("ID",seq(1:length(Areas)))
dhrus <- initdHruModel(nHrus,Areas,IdsHrus)
prec=c(100,200,300,100,200,300)
temp=c(1,2,3,1,2,3)
setGWtypeToAlldHrus(dhrus,gwTypes = rep("LIN_RES", times =nHrus), IdsHrus)
setPTInputsToAlldHrus(dhrus, Prec = prec, Temp = temp, as.Date("1990/01/30"))
ParDF = data.frame( B_SOIL = 1.6, C_MAX = 100, B_EVAP = 2,  KS = 0.5, KF = 0.5, ADIV = 0.5, CDIV = 0.03,
SDIV = 0.03, CAN_ST = 2, STEM_ST = 2, CSDIV = 0.3, TETR = 5, DDFA = 0.5, TMEL = 0, RETCAP = 0 )
setParamsToAlldHrus(dHRUM_ptr = dhrus,as.numeric(ParDF[1,]),names(ParDF))
calcPetToAllHrus(dHRUM_ptr = dhrus,50.1,"THORNTHWAITE")
calcHBInAlldHrus(dHRUM_ptr = dhrus)
gatherHBdata(dHRUM_ptr = dhrus)
outDta <- getOutputDist(dHRUM_ptr = dhrus)
outDF <- cbind(outDta$outDta, outDta$Ids)
outDF <- data.frame(outDF)
names(outDF) <-c(outDta$VarsNams,"HruIDs")

outDF


#' Compute the slope along the river channel
#'
#' This computes the change in elevation from one watershed unit to the next. Computation by
#' pixel is only recommended if the elevation model used to create the watershed is very
#' accurate; otherwise unrealistic slopes can occur. Reach-based computation uses a much
#' larger range of pixels to compute the slope, and so is less prone to DEM errors.
#'
#' @param ws A watershed
#' @param by Should the slope be computed for each reach (recommended) or from one pixel to the
#' next
#'
#' @return A vector of slopes, one per pixel
#' @examples
#' \donttest{
#' ws_slope(ws)
#' ws_slope(ws, by = "pixel")
#' }
#' @export
ws_slope = function(ws, by = c("reach", "pixel")) {
	by = match.arg(by)
	if(by == "pixel") {
		adj = methods::as(ws$adjacency, "dgTMatrix")
		adj = cbind(adj@i + 1, adj@j + 1, adj@x) ## Matrix is 0-indexed

		## this function assumes the adjacenty matrix is unweighted
		adj[,3] = ws$data$length[adj[,2]]
		delev = ws$data$elevation[adj[,1]] - ws$data$elevation[adj[,2]]

		slope = numeric(nrow(ws$data)) * NA
		slope[adj[,1]] = delev/adj[,3]
		slope[adj[,2]] = delev/adj[,3]
		slope = abs(slope)
	} else {
		delev = tapply(ws$data$elevation, ws$data$reachID, function(x) max(x) - min(x))
		length = tapply(ws$data$length, ws$data$reachID, sum)
		slope = delev / length
		slope = slope[match(ws$data$reachID, names(slope))]
	}
	return(slope)
}

#' Nearest neighbors of pixels
#' @keywords internal
ds = function(pix, ws) {
	val = which(ws$adjacency[,pix] == 1)
	if(length(val) == 0)
		val = NA
	val
}

#' Nearest neighbors of pixels
#' @keywords internal
us = function(pix, ws) {
	val = which(ws$adjacency[pix,] == 1)
	if(length(val) == 0)
		val = NA
	val
}

#' Produces a site by pixel distance matrix
#'
#' Note that pixels in the watershed that are not connected to any of the sites will be excluded
#' from the result.
#' @param ws A watershed
#' @param x A vector of sites
#' @param variable The variable to use as the distance
#' @return A site by pixel distance matrix
#' @export
wsDistance <- function(ws, x, variable = 'length') {
	downs <- parallel::mclapply(x, function(xx) {
		res <- accumulate(ws, xx, parallel=FALSE, variable = variable)
		if(!is.matrix(res)) res <- matrix(res, nrow=1)
		res
	})
	ups <- parallel::mclapply(x, function(xx) {
		res <- accumulate(ws, upstream=Inf, downstream = xx, parallel = FALSE,
			direction = 'up', variable = variable)
		if(!is.matrix(res)) res <- matrix(res, nrow=1)
		res
	})

	matTall <- do.call(rbind.data.frame, mapply(function(xx, ds, us) {
		dsMat <- cbind(row=rep(xx, nrow(ds)), col = ds[,1], val = ds[,2])
		usMat <- cbind(row=rep(xx, nrow(us)), col = us[,1], val = us[,2])
		rbind(dsMat, usMat)
	}, xx = x, ds = downs, us = ups))
	matWide <- reshape2::acast(matTall, row ~ col, value.var = 'val',
		fun.aggregate = function(x) ifelse(length(x) == 0, NA, x[1]), fill=NA_real_, drop=FALSE)

	matWide[order(as.integer(rownames(matWide))), order(as.integer(colnames(matWide)))]
}

#' Returns all points in the watershed connecting two points
#'
#' This is a simple wrapper to accumulate that only returns the pixels
#' @param ws Watershed object
#' @param upstream ID number of upstream point; if Inf ALL upstream pixels will be returned
#' @param downstream ID of downstream point; if Inf ALL downstream pixels will be returned
#'
#' @return A vector of pixel ids
#' @export
connect <- function(ws, upstream, downstream = Inf) {
	direction <- "down"
	if(is.infinite(upstream))
		direction <- "up"
	accumulate(ws, upstream, downstream, direction)[,1]
}

#' Returns all points in the watershed connecting two points, accumulating a value between
#'
#' If direction is down, then the accumulated distances will reflect the distance from the
#' `upstream` point to each downstream point, and values will be positive. If direction is "up",
#' then the distances will be negative and accumulate from `downstream` to `upstream`.
#' @param ws Watershed object
#' @param upstream ID number of upstream point; if Inf ALL upstream pixels will be returned
#' @param downstream ID of downstream point; if Inf ALL downstream pixels will be returned
#' @param direction In which direction should the variable be accumulated; see 'details'
#' @param variable The variable to accumulate
#' @param parallel Boolean, should parallel processing be used?
#' @return A matrix, first column connected pixelIDs, second the accumulated variable
#' @export
accumulate <- function(ws, upstream, downstream = Inf, direction = c("down", "up"),
			variable = 'length', parallel = FALSE) {
	direction <- match.arg(direction)
	if(parallel && !requireNamespace("parallel"))
		parallel <- FALSE
	dsPixes <- downstreamPixelIds(ws)
	if(length(downstream) == 1 && is.infinite(downstream))
		downstream <- outlets(ws)$id
	if(length(downstream) == 1) {
		if(length(upstream) == 1 && is.infinite(upstream)) {
			rid <- ws[downstream, 'reachID']
			tops <- headwaters(ws)[,'id']
			upReaches <- Matrix::which(ws$reach_connectivity[rid,] == 1)
			if(rid %in% ws[tops, 'reachID'])
				upReaches <- c(upReaches, rid)
			upstream <- tops[ws[tops, "reachID"] %in% upReaches]
		}
		if(length(upstream) == 1) {
			accum <- do.call(cbind, connectCPP(dsPixes, upstream, downstream, ws[, variable]))
			if(direction == 'up')
				accum[,2] <- accum[,2] - accum[accum[,1] == downstream,2]
		} else {
			if(parallel) {
				accum <- do.call(rbind,
					parallel::mclapply(upstream, function(x)
						accumulate(ws, x, downstream, direction, variable)))
			} else {
				accum <- do.call(rbind, lapply(upstream, function(x)
						accumulate(ws, x, downstream, direction, variable)))
			}
		}
	} else {
		accum <- do.call(rbind,
				lapply(downstream, function(x) accumulate(ws, upstream, x, direction,
					variable, parallel)))
	}
	## remove redundancies; it is quite common to traverse the same pixel multiple times
	accum <- accum[!duplicated(accum[,1]),, drop=FALSE]
	return(accum)
}

#' Produce a site by reach connectivity matrix
#'
#' A value of 1 at indices `[i,j]` indicates that reach `i` is connected to (i.e., downstream of)
#' reach `j`.
#' @param ws A watershed object
#' @param points A vector of pixel id numbers for sites
#' @param names An optional vector of site names
#' @param self If TRUE, a reach is considered connected to itself
#' @return A [Matrix::sparseMatrix()]
#' @export
siteByReach <- function(ws, points, names, self = TRUE) {
	rIDs <- ws[points, 'reachID']
	conn <- ws$reach_connectivity
	if(self)
		diag(conn) <- rep(1, nrow(conn))
	mat <- conn[rIDs,, drop=FALSE]
	if(missing(names)) {
		rownames(mat) <- points
	} else {
		rownames(mat) <- names
	}
	mat
}

#' Construct a matrix identifying the nearest downstream neighbor from a list of sites
#'
#' @param ws A watershed
#' @param x A vector of pixel IDs
#' @param names Optional vector of site names
#' @return A 2-column matrix; the first column gives the ID of a pixel, the second its nearest
#' downstream neighbor. Pixels in `x` that have no nearest neighbor are excluded.
#' If 'names' is specified, the output matrix will give site names instead of pixelIDs
#' @export
nearestDownstreamNeighbor <- function(ws, x, siteNames) {
	dmat <- downstreamDist(ws, x)
	res <- do.call(c, apply(dmat, 1, function(x) {
		if(all(x == 0)) {
			NULL
		} else {
			x[x==0] <- Inf
			names(x)[which.min(x)]
		}
	}))
	mat <- cbind(from=as.integer(names(res)), to=as.integer(res))
	if(!missing(siteNames)) {
		mat <- cbind(from=siteNames[match(mat[,1], x)], to=siteNames[match(mat[,2], x)])
	}
	mat
}

#' Build a downstream distance matrix for a list of sites
#'
#' For each site, this function identifies the other sites that are downstream of it and computes
#' a 'distance' between each site and all of its downstream sites. By default, this is river,
#' distance, computed by summing the length of stream between the two sites. For any entry in
#' this distance matrix [i,j], the value is either a nonzero number giving the downstream
#' distance from site i to site j, or zero, indicating that j is not downstream of i.
#'
#' For a more general (and much slower) distance computation, see [wsDistance()]
#'
#' @param ws A watershed
#' @param x A vector of pixel ids
#' @param variable The variable to use for the distance metric
#' @param fun The function to apply between each pair of sites
#' @return A site by site distance [Matrix::sparseMatrix()]
#' @export
downstreamDist <- function(ws, x, variable = 'length', fun = sum) {
	res <- parallel::mclapply(x, function(i) {
		dspix <- connect(ws, i, Inf)
		dsSites <- x[which(x %in% dspix & !x==i)]
		if(length(dsSites) == 0) {
			NULL
		} else {
			t(sapply(dsSites, function(j) {
				ijPixes <- connect(ws, i, j)
				c(i, j, fun(ws[ijPixes, variable]))
			}))
		}
	})
	res <- do.call(rbind, res)
	res[,1] <- match(res[,1], x)
	res[,2] <- match(res[,2], x)
	Matrix::sparseMatrix(i = res[,1], j = res[,2], x = res[,3],
		dims = c(length(x), length(x)), dimnames = list(x, x))
}

#' Find the nearest neighbors for a focal pixel among a list of sites
#'
#' For a list of `sites`, this function first computes a distance matrix(if not specified),
#' then finds the nearest upstream and downstream neighbors for focal pixels `x`. Note that
#' `x` does not necessarily have to be in the list of sites, they can be anywhere in the watershed.
#'
#' @param ws A watershed, optional unless `distMatrix` is missing
#' @param x A vector of focal pixels (always required)
#' @param distMatrix A site by pixel distance matrix, will be computed if not specified
#' @param sites A list of sites for the distance matrix, required if distMatrix is missing
#' @param selfAdjacency if TRUE, a site can be downstream of itself
#'
#' @return A list with a downstream and an upstream element. Each element is a matrix, where
#' the first column corresponds to the focal pixels in `x`, and the second column lists the
#' nearest neighbors in `sites`.
#' @export
nearestNeighbors <- function(ws, x, distMatrix, sites, selfAdjacency = FALSE) {
	if(missing(distMatrix))
		distMatrix <- wsDistance(ws, sites)

	if(length(x) > 1) {
		res <- lapply(x, function(xx) nearestNeighbors(ws, xx, distMatrix,
			selfAdjacency = selfAdjacency))
		resds <- do.call(rbind, lapply(res, function(xx) xx$downstream))
		resus <- do.call(rbind, lapply(res, function(xx) xx$upstream))
		return(list(downstream = resds, upstream = resus))
	}

	x <- as.character(x)

	# nearest downstream neighbor is easy, there is just one
	if(selfAdjacency & x %in% rownames(distMatrix)) {
		ds <- x
	} else if(! x %in% colnames(distMatrix)) {
		ds <- numeric(0)
	} else {
		ds <- dsNeighbors(x, distMatrix)
		ds <- rownames(distMatrix[ds,x, drop=FALSE])[which.max(distMatrix[ds,x])]
	}
	if(length(ds) > 0) {
		ds <- c(as.integer(x), as.integer(ds))
	} else
		ds <- NULL

	# for upstream, we look for upstream neighbors that have no downstream neighbors
	# within the set of all upstream neighbors (in other words, their only downstream neighbors)
	# are either the site x or sites downstream of x
	if(selfAdjacency & x %in% rownames(distMatrix)) {
		us <- x
	} else if(! x %in% colnames(distMatrix)) {
		us <- numeric(0)
	} else {
		us <- usNeighbors(x, distMatrix)
		us_ds <- lapply(us, dsNeighbors, distMatrix = distMatrix[us,,drop = FALSE])
		if(length(us_ds) == 0) {
			us <- character(0)
		} else
			us <- us[sapply(us_ds, function(xx) all(is.na(xx)))]
	}

	if(length(us) > 0) {
		us <- cbind(as.integer(x), as.integer(us))
	} else
		us <- NULL

	list(downstream = ds, upstream = us)
}

# returns all downstream neighbors given a distance matrix
#' @keywords internal
dsNeighbors <- function(x, distMatrix) {
	nbs <- distMatrix[,x]
	names(nbs)[which(nbs < 0)]
}

# returns all upstream neighbors given a distance matrix
#' @keywords internal
usNeighbors <- function(x, distMatrix) {
	nbs <- distMatrix[,x]
	names(nbs)[which(nbs > 0)]
}


#' Channel Shape
#'
#' Calculates metrics that describe shape of the COMIDs wihtin a network
#'
#' @param network a single network extracted from NHDPlusV2
#' @param elevslope NHDPlusV2 elevation slope table, elevslope.dbf"
#'
#' @return data.frame of NHDPlusV2 attributes: slope (\code{SLOPE}), smoothed
#' maximum \code{MAXELEVSMO} and minimum elevation (\code{MINELEVSMO}) and
#' COMID length (\code{LENGTHKM}), mean elevation (\code{elev}) and channel sinuosity
#' (\code{sinuosity}).
#'
#' @details
#' Elevation is the mean of the smoothed max and min elevation
#'
#' Sinuosity is COMID length divided by straight line length
#'
#'
#' @export

chn_geom <- function (network, elevslope){
  slope <- elevslope
  names(slope) <- toupper(names(slope))
  net <- sf::st_transform(network, crs = 5070)

  slopeelev <- slope[slope$COMID%in%network$COMID, c("COMID", "SLOPE", "MAXELEVSMO", "MINELEVSMO")]
  slopeelev$elev <- apply(slopeelev[,c("MAXELEVSMO", "MINELEVSMO")],1,mean)

  # to ensure the input is linestring geometry -
  # vpu 17 read in a multiline and caused error
  net <- suppressWarnings(sf::st_cast(net, "LINESTRING"))
  tot.len <- sf::st_length(net)

  xy <- sf::st_coordinates(net)
  xy <- data.frame(xy)
  xy <- split(xy, xy$L1)
  #create line string from 1st and lask point of each comid
  xy <- lapply(xy, function(x) sf::st_linestring(as.matrix(rbind(x[1, c("X", "Y")], x[nrow(x), c("X", "Y")]))))

  #name list elements
  names(xy) <- net$COMID

  #check plots
  #plot(st_geometry(net[net$COMID==23963061,]))
  #plot(xy[["23963061"]], add = T)

  #calculate channel sinuosity
  sinuosity <- do.call(rbind, sapply(net$COMID, simplify = F, function(x)
    data.frame(COMID = x,
               LENGTHKM = net$LENGTHKM[net$COMID==x],
               sinuosity = sf::st_length(net[net$COMID==x,]) / sf::st_length(xy[[as.character(x)]]))))
  sinuosity$sinuosity <- units::set_units(sinuosity$sinuosity, NULL)
  out <- merge(slopeelev, sinuosity, by = "COMID")

  return(out)
}

#' Confluence Attributes
#'
#' Calculates metrics related to confluences in a network
#'
#' @param network a single network extracted from NHDPlusV2
#' @param vaa NHDPlusV2 value added attributes table, PlusFlowlineVAA.dbf"
#' @param flow NHDPlusV2 flow table, PlusFlow.dbf
#'
#' @return data.frame of confluence angle (\code{Confl_angle}),
#' area ratio (\code{AreaRatio}), total upstream area \code{Confl_AREA},
#' order of the tributary (\code{Confl_order}), and tributary classification
#' \code{Confl_class}
#'
#' @details Lambert Conformal Cone (crs = 102004) used to
#' preserve angles Seybold et al. (2017) is no longer available
#'
#' in some cases tributary angle is NAN because average tributary direction is near verticle.
#' the function cannot determine starts/end of line needed to calculate direction position
#' vector direction. this could be could fix this by changing the maximum verticies
#'
#' Complex confluences >2 tributaries are incorrect.
#'
#' Confluence angle is the angle two tributarys meet. Calculated as the intersection between
#' two slopes orthoganal regression slopes reflecting each tributary's average direction
#'
#' Area ratio is the ratio of the tributary catchment area to the mainstem catchment area. Mainstem
#' is identified as tributary with the largest catchment area
#'
#' confluence area is the total area upstream of the confluence
#'
#' confluence order is the stream order directly downstream of the confluence
#'
#' confluence class is the stream order of each tributary in the confluence
#'
#' @export

net_confl <- function (network, vaa, flow){

  names(vaa) <- toupper(names(vaa))
  names(flow) <- toupper(names(flow))

  NHD <- network
  #NHD <- sf::st_cast(NHD,"LINESTRING")
  #Lambert Conformal Cone - preserves angles as per seybold et al 2017
  #NHD <- sf::st_transform(NHD, crs = 102009)

  NHD <- merge(NHD, vaa[, c("COMID", "STREAMORDE", "STREAMCALC", "STREAMLEVE", "TOTDASQKM")], by = "COMID")

  #remove divergent flow paths
  NHD <- NHD[NHD$STREAMORDE == NHD$STREAMCALC, ]

  #identify confluences (>1 flowline upstream)
  confluences <- lapply(split(NHD, as.character(NHD$COMID)),
                        function(x) flow[flow$TOCOMID == x$COMID, "FROMCOMID"])

  #ind <- unlist(lapply(confluences, function(x) length(x) > 1))

  confluences <- lapply(confluences, function(x) NHD[NHD$COMID%in%x,])
  ind <- unlist(lapply(confluences, function(x) nrow(x))>1)
  confluences <- confluences[ind]

  angles <- do.call(rbind,lapply(confluences, function(q){
    coords <- list(q[1,], q[2,])
    coords <- lapply(coords, function(z) sf::st_coordinates(z))
    pos <- lapply(coords,function(x) pos_vec(x, diagnostics = F))
    angle_deg <- vec_angle(pos[[1]], pos[[2]])
    return(angle_deg)
  }))

  #angles <- do.call(rbind,lapply(confluences, function(q) confluence_angle(q[1,],q[2,])))
  colnames(angles) <- "Confl_angle"

  #summarize vaa table valuse from upstream confluences
  attrssum <- do.call(rbind,lapply(confluences, function(t)
    data.frame(AreaRatio = min(t$TOTDASQKM) / max(t$TOTDASQKM),
               Confl_AREA = sum(t$TOTDASQKM),
               Confl_ord = ifelse(anyDuplicated(t$STREAMORDE),
                                  unique(t$STREAMORDE) + 1,
                                  max(t$STREAMORDE)),
               Confl_class = paste(t$STREAMORDE[order(t$STREAMORDE)],
                                   collapse = "."))))

  out <- merge(angles, attrssum, by = 0)
  names(out)[1] <- "COMID"

  return(out)
}

#' Average line direction
#'
#' Calculates average direction of a line used for concluence angle
#'
#' @param p an points of an sf LINESTRING
#' @param maxvert maximum number of line verticies used to fit regression
#' @param diagnostics logical used for plotting
#'
#' @return position vector of a line unless diagnostics = T
#'
#' @details this function uses orthogonal regression to find the
#' average direction of a series of points and returns
#' the position vector.
#'
#' max vert is the maximum number of verticies to fit average line
#'
#' in some instances the function will return NAN when
#' line is near verticle. Could fix this by changing the
#' maximum verticies
#'
#' @example
#' #two lines
#' x <- confluences[[54]][1,]
#' y <- confluences[[54]][2,]
#'
#' #coordinates for each line
#' coords <- list(x, y)
#' coords <- lapply(coords, function(z) sf::st_coordinates(z))
#'
#' #apply each function over
#' pos <- lapply(coords,function(x) pos_vec(x, diagnostics = T))
#'
#' #plot diagnostics
#' plot(st_coordinates(confluences[[54]]))
#'
#' abline(pos[[1]]$y_int1, pos[[1]]$beta1)
#' abline(pos[[2]]$y_int1, pos[[2]]$beta1)
#'
#' points(pos[[1]]$start, pch = 19, col = "green")
#' points(pos[[1]]$end, pch = 19, col = "red")
#'
#' points(pos[[2]]$start, pch = 19, col = "green")
#' points(pos[[2]]$end, pch = 19, col = "red")
#' @export

pos_vec <- function(p , maxvert = nrow(p), diagnostics = T){
  #p <- st_coordinates(sfline)
  #plot(st_geometry(st_as_sf(data.frame(p), coords=c("X","Y"), crs = st_crs(sfline))), add = T)
  #maxvert = nrow(p)-2
  #p <- coords[[2]]

  #only considering the 1st 5 vertices from confluence
  if(nrow(p)>maxvert){
    p <- p[(nrow(p)-maxvert):nrow(p),]
  }

  x1 <- p[, c(1)]
  y1 <- p[, c(2)]

  #plot(x1,y1, ylim = c((min(y1) - 0.002), (max(y1)+0.003)),
  #     xlim = c((min(x1)-0.002), (max(x1)+0.003)))
  #average tributary direction orthogonal regression (total) on x y coords
  #this is the average direction of the flowline, orthogonal regression
  #minimizes perpendicular error
  v <- stats::prcomp(cbind(x1, y1))$rotation
  beta1 <- v[2,1] / v[1,1]

  #given the average direction of the trib, find intercept.
  #force lines to pass through confluence
  #the last row is start in coords subset is start (confluence)

  #y_int1 <- y1[length(y1)] - beta1 * x1[length(x1)]
  #new_xy1_1 <- cbind(x1[length(x1)], y1[length(y1)])

  y_int1 <- mean(y1) - beta1 * mean(x1)
  #abline(y_int1, beta1)
  new_xy1_1 <- data.frame(X = x1, Y = beta1 * (x1) + y_int1)

  closest <- as.matrix(stats::dist(rbind(data.frame(X = x1[length(x1)],
                                                    Y = y1[length(y1)]),
                                         new_xy1_1)))[1,]
  new_xy1_1 <- new_xy1_1[which.min(closest[-1]),]
  #points(new_xy1_1, col = "green")
  #the first row is the terminous
  #find the predicted point that is closest to the
  #most upstream end of the flowline. needed to define
  #the correct direction of the vector because some
  new_xy1_2 <- data.frame(X = x1, Y = beta1 * (x1) + y_int1)

  closest <- as.matrix(stats::dist(rbind(data.frame(X = x1[1],
                                                    Y = y1[1]),
                                         new_xy1_2)))[1,]
  new_xy1_2 <- new_xy1_2[which.min(closest[-1]),]
  #points(new_xy1_2, col = "red")
  #position vector is terminus minus start
  #makes vector start at orgin (0,0)
  pos_vec_xy1 <- new_xy1_2 - new_xy1_1

  if(diagnostics){
    return(list(pos_vec_xy1 = pos_vec_xy1,
                start = new_xy1_1,
                end = new_xy1_2,
                y_int1 = y_int1,
                beta1 = beta1))
  } else {

    return(pos_vec_xy1)

  }
}

#' Intersection Angle
#'
#' @param pos1 position vector of line 1
#' @param pos2 position vector of line 2
#' @param deg logical return angle in degrees
#'
#' @return intersection angle of two positon vectors
#'
#' @example
#' pos1 <- c(2,2)
#' pos2 <- c(0,3)
#'
#' dat<-rbind(pos1, c(0,0), pos2, c(0,0))
#'
#' vec_angle(pos1, pos2)
#'
#' plot(dat, xlim = c(-3,3), ylim = c(-3,3))
#'
#' lines(dat)
#'
#' @export

vec_angle <- function(pos1, pos2, deg =T){
  #dot product divided by magnitude
  alpha <- acos(sum(pos1 * pos2) / (sqrt(sum(pos1^2)) * sqrt(sum(pos2^2))))

  if(deg){
    alpha<-(alpha  * 180) / (base::pi)#in degs
  }
  return(alpha)
}

#' Network StreamCat Data
#'
#' Extracts StreamCat variables for Network COMID
#'
#' @param comid NHDPlusV2 COMID
#' @param strcat_path directory containing StreamCat data
#' @param csvfile Name of StreamCat File
#' @param vpu NHDPlusV2 Vector Processing Unit
#'
#' @return \code{data.frame} of streamCat variables
#'
#' @export
#'

get_streamcat <- function (comid, strcat_path = "Data/StreamCat",
                           csvfile = "Lithology", vpu = "01"){

  Region_dir <- grep(vpu, list.dirs(strcat_path), value = T)
  f_name <- grep(csvfile, list.files(Region_dir, full.names = T), value = T)

  if(length(f_name) != 1){
    stop("multiple StreamCat files, give more specific name")
  }

  strcat <- utils::read.csv(file = f_name)

  out <- strcat[strcat$COMID %in% comid, ]

  return(out)
}


# Databricks notebook source
library("testthat")
# library("SparkR")

context("Regression Tests Linear Regression Model with Dataset")

# test_env is the test environment global var

# Set model(s) path
if(is_testing()){
  # If testing, get input model directory from test env passed in to script
  base_dir <- test_env$base_dir
  inputmodel_path <- paste(base_dir,"models","model.rds",sep = "/")
  data_test_path <- test_env$data_test_path
  data_train_path <- test_env$data_train_path
} else{
  # else load path manually for interactive/dev test
  inputmodel_path <- "/dbfs/mnt/adlsv2-databricks/build/RModel-Repo/454/models/model.rds"
  data_test_path <- "/dbfs/mnt/adlsv2-databricks/data/build-test/r_input_file1.csv"
  data_train_path <- "/dbfs/mnt/adlsv2-databricks/data/build-test/weight_data.csv"
}

# COMMAND ----------

# Load Input Data
data <- read.csv(data_test_path, header=TRUE)

# Load the Model from Blob Storage
model <- readRDS(inputmodel_path)

# Perform Scoring
x <- data.frame(x = data$height)
y <- predict(model,x)
data$weight <- y

# Load Training Data
data_t <- read.csv(data_train_path, header=TRUE)

# Calculate Diff
dif <- data.frame(data_t, data)
r_sqr <- cor(dif$weight, dif$weight.1)^2

# COMMAND ----------

# Actual Test Case
# We know that in training the R_Squred is 0.007663
train_r_sqr <- 0.007663
testName <- "Dif R_Sqrs"
test_that(testName, {
  expect_lt(abs(r_sqr - train_r_sqr), 0.001)
})


library(pheatmap)
library(gplots)

#-------------------------------------------------------------------------------
# Transform into a matrix
#-------------------------------------------------------------------------------

exprList2Matrix <- function( exprList ) {
	# Length of all lists
	lengths <- unlist( lapply( 1:length(exprList), function(x) length(unlist(exprList[[x]])) ) )
	ncol <- max(lengths)
	nrow <- length(lengths)
	exprMatrix <- matrix(data = NA, nrow = nrow, ncol = ncol)

	for( i in 1:nrow ) {
		len <- lengths[i]
		cat('\ti:', i, '\tLength', len, '\n')
		exprMatrix[i,1:len] <- unlist( exprList[[i]] )
	}

	return (exprMatrix)
}

#-------------------------------------------------------------------------------
# Box plot of a matrix
#-------------------------------------------------------------------------------
boxplotMatrix <- function( exprMatrix, title ) {
	# Colorize according to values
	m <- t(exprMatrix)
	means <- colMeans(m, na.rm=T)

	numCols <- 100
	minMean <- -4.5
	maxMean <- 4.5
	cols <- cols <- heat.colors(numCols, alpha = 1)
	colIdx <- round( (numCols-1) * (means - minMean ) / (maxMean  - minMean) + 1 )

	boxplot( m, las=2, col=cols[colIdx], ylim=c(minMean, maxMean), main=title )
	abline( h=0, lty=2, col='grey' )
}

#-------------------------------------------------------------------------------
# Main
#-------------------------------------------------------------------------------

usePdf <- T
if( usePdf) { pdf( width=3, height=50, "boxPlots.pdf"); }

# Read data
d <- read.table('heatMap.txt', sep='\t', header=TRUE)
dm <- as.matrix(d)
dmn <- dm

colnames(dmn) <- NULL
rownames(dmn) <- NULL

lab <-  unlist(colnames(dm))

tissues <- c("Brain", "Liver", "Pancreas", "Muscle_Skeletal", "Adipose_Subcutaneous", "Adipose_Visceral")
tissuesShort <- c("Brain", "Liver", "Pancreas", "Skeletal", "Subcut.", "Visceral")

par(mfcol=c(25,1) )

for( geneIdx in 1:dim(dm)[1] ) {
	gene <- rownames(dm)[geneIdx]

	cat('Gene:', gene, '\n')
	exprList <- list()

	for( tissue in tissues ) {
		cat('\tTissue:', tissue, '\n');
		keep <- unlist( lapply( lab, function(x) ! is.na( pmatch(tissue , x)) ) )

		# Append list to list of expressions
		exprList[[ length(exprList)+1 ]] <- list( unlist(dmn[geneIdx,keep]) )
	}

	# Convert to matrix (fill with NA)
	exprMatrix <- exprList2Matrix(exprList)
	# Add tissue names
	rownames(exprMatrix) <- tissuesShort
	# Boxplot
	boxplotMatrix( exprMatrix, gene )
}

if( usePdf ) { dev.off(); }


#' Make a movie of the diffusion of probability, P1, from a starting node.
#'
#' Recursively diffuse probability from a starting node based on the connectivity of the background knowledge graph, representing the
#' likelihood that a variable will be most influenced by a perturbation in the starting node.
#' @param p1 - The probability being dispersed from the starting node, startNode.
#' @param startNode - The first variable drawn in the node ranking, from which p1 gets dispersed.
#' @param G - A list of probabilities, with names of the list being the node names in the background knowledge graph.
#' @param visitedNodes - A character vector of node names, storing the history of previous draws in the node ranking.
#' @param graphNumber - If testing against multiple background knowledge graphs, this is the index associated with the adjacency matrix that codes for G. Default value is 1.
#' @return G - A list of returned probabilities after the diffusion of probability has truncated, with names of the list being the node names in the background knowledge graph.
#' @export graph.diffuseP1Movie
#' @keywords generative methods
#' @keywords diffusion event
#' @keywords network walker
#' @examples
#' # 7 node example graph illustrating diffusion of probability based on network connectivity
#' # from Thistlethwaite et al., 2019.
#' adj_mat = rbind(c(0,2,1,0,0,0,0), # A
#'                 c(2,0,1,0,0,0,0), # B
#'                 c(1,0,0,1,0,0,0), # C
#'                 c(0,0,1,0,2,0,0), # D
#'                 c(0,0,0,2,0,2,1), # E
#'                 c(0,0,0,1,2,0,1), # F
#'                 c(0,0,0,0,1,1,0)  # G
#'                 )
#' rownames(adj_mat) = c("A", "B", "C", "D", "E", "F", "G")
#' colnames(adj_mat) = c("A", "B", "C", "D", "E", "F", "G")
#' adjacency_matrix = list(adj_mat)
#' ig = graph.adjacency(as.matrix(adj_mat), mode="undirected", weighted=TRUE)
#' G=vector(mode="list", length=7)
#' G[1:length(G)] = 0
#' names(G) = c("A", "B", "C", "D", "E", "F", "G")
#' startNode = "A"
#' visitedNodes = startNode
#' # Diffuse 100% of probability from startNode "A"
#' p1 = 1.0
#' # Probability diffusion truncates at
#' thresholdDiff=0.01
#' coords = layout.fruchterman.reingold(ig)
#' V(ig)$x = coords[,1]
#' V(ig)$y = coords[,2]
#' # Global variable imgNum
#' imgNum=1
#' G_new = graph.diffuseP1Movie(p1, startNode, G, visitedNodes, ig, 1, getwd())
graph.diffuseP1Movie = function(p1, startNode, G, visitedNodes, ig, recursion_level=1, output_dir=getwd()) {
  #print(sprintf("%sprob. to diffuse:%f startNode: %s, visitedNodes: %s",
  #              paste(rep("   ", length(visitedNodes) - 1), collapse = ""),
  #              p1, startNode, toString(visitedNodes)))
  #print(sprintf("ImgNum=%d", imgNum))

  V(ig)$color = rep("blue", length(G))
  V(ig)$color[which(V(ig)$name %in% visitedNodes)] = "red"
  V(ig)$label = sprintf("%s:%.2f", V(ig)$name, G)
  png(sprintf("%s/diffusionEventMovie%d.png", output_dir, .GlobalEnv$imgNum), 500, 500)
  plot.igraph(ig, layout=cbind(V(ig)$x, V(ig)$y), vertex.color=V(ig)$color,
              vertex.label=V(ig)$label, vertex.label.dist = 3, edge.width=5*abs(E(ig)$weight),
              mark.col="black", mark.border = "black", mark.groups = startNode)
  title(sprintf("Diffuse %.2f from %s at recursion level %d.", p1, startNode, recursion_level), cex.main=1)
  legend("bottomright", legend=c("Visited", "Unvisited"), fill=c("red", "blue"))
  dev.off()
  .GlobalEnv$imgNum=.GlobalEnv$imgNum+1

  adj_mat = as.matrix(get.adjacency(ig, attr = "weight"))
  startNodeNeighbors = names(which(abs(adj_mat[, startNode]) >  0))
  startNodeUnvisitedNeighbors = startNodeNeighbors[!(startNodeNeighbors %in% visitedNodes)]
  vN = visitedNodes[which(visitedNodes != startNode)]
  extendedConnections = NULL
  if (length(vN) > 0 && length(startNodeUnvisitedNeighbors) == 0) {
    adj_matAfter = adj_mat[-which(rownames(adj_mat) %in% vN), -which(colnames(adj_mat) %in% vN)]
    connections = adj_mat[startNode, ]
    connectionsYes = connections[which(abs(connections) > 0)]
    connectionsNo = connections[intersect(which(connections == 0), which(!(names(connections) %in% c(startNode, vN))))]
    if (length(connectionsNo) > 0) {
      for (n1 in 1:length(connectionsNo)) {
        if (length(connectionsYes) > 0) {
          for (n2 in 1:length(connectionsYes)) {
            if (abs(adj_mat[names(connectionsYes[n2]), names(connectionsNo[n1])]) > 0) {
              connectionsNo[n1] = adj_mat[names(connectionsYes[n2]), names(connectionsNo[n1])]
              extendedConnections = c(extendedConnections, connectionsNo[n1])
            }
          }
        }
      }
    }
    if (length(extendedConnections) > 0) {
      adj_matAfter[startNode, names(extendedConnections)] = extendedConnections
      adj_matAfter[names(extendedConnections), startNode] = extendedConnections
    }
    adj_mat = adj_matAfter
  }
  startNodeNeighbors = names(which(abs(adj_mat[, startNode]) > 0))
  startNodeUnvisitedNeighbors = startNodeNeighbors[!(startNodeNeighbors %in% visitedNodes)]
  if (length(startNodeUnvisitedNeighbors) > 0 || length(extendedConnections) > 0) {
    weighted_edges.sum = sum(abs(adj_mat[which(rownames(adj_mat) %in% startNodeUnvisitedNeighbors), startNode]))
    #print(sprintf("%sWeighted_edges.sum=%f", paste(rep("   ", length(visitedNodes) - 1), collapse = ""), weighted_edges.sum))
    z = 1
    while (z <= length(startNodeUnvisitedNeighbors)) {
      inherited.probability = p1 * abs(adj_mat[startNodeUnvisitedNeighbors[z], startNode])/weighted_edges.sum
      G[[startNodeUnvisitedNeighbors[z]]] = G[[startNodeUnvisitedNeighbors[z]]] + inherited.probability

      #print(sprintf("%sadded diffused  probability %f to child #%d: %s", paste(rep("   ", length(visitedNodes) - 1), collapse = ""), inherited.probability, z, startNodeUnvisitedNeighbors[z]))

      V(ig)$color = rep("blue", length(G))
      V(ig)$color[which(V(ig)$name %in% visitedNodes)] = "red"
      V(ig)$label = sprintf("%s:%.2f", V(ig)$name, G)
      #tmp = rep(0.01, length(E(ig)$weight))
      #tmp[get.edge.ids(ig, vp=c(startNode, startNodeUnvisitedNeighbors[z]))] = 1
      lbls = rep("", length(E(ig)$weight))
      lbls[get.edge.ids(ig, vp=c(startNode, startNodeUnvisitedNeighbors[z]))] = round(inherited.probability, 3)
      png(sprintf("%s/diffusionEventMovie%d.png", output_dir, .GlobalEnv$imgNum), 500, 500)
      plot.igraph(ig, layout=cbind(V(ig)$x, V(ig)$y), vertex.color=V(ig)$color,
                  vertex.label=V(ig)$label, vertex.label.dist = 3, edge.label = lbls, edge.width=5*abs(E(ig)$weight),
                  mark.col="black", mark.border = "black", mark.groups = startNode)
      title(sprintf("Diffuse %.2f from %s at recursion level %d.", p1, startNode, recursion_level), cex.main=1)
      legend("bottomright", legend=c("Visited", "Unvisited"), fill=c("red", "blue"))
      dev.off()
      .GlobalEnv$imgNum = .GlobalEnv$imgNum + 1

      nNeighbors = names(which(abs(adj_mat[, startNodeUnvisitedNeighbors[z]]) >  0))
      if (length(nNeighbors) > 0 && inherited.probability/2 > thresholdDiff && ((length(visitedNodes) + 1) < length(G))) {
        G[[startNodeUnvisitedNeighbors[z]]] = G[[startNodeUnvisitedNeighbors[z]]] - inherited.probability/2

        #print(sprintf("%ssubtracted %f from startNode's neighbor #%d: %s and sent to its own neighbors.",
        #                paste(rep("   ", length(visitedNodes) - 1), collapse = ""), inherited.probability/2,
        #                z, startNodeUnvisitedNeighbors[z]))

        V(ig)$color = rep("blue", length(G))
        V(ig)$color[which(V(ig)$name %in% visitedNodes)] = "red"
        V(ig)$label = sprintf("%s:%.2f", V(ig)$name, G)
        #tmp = rep(0.01, length(E(ig)$weight))
        #tmp[get.edge.ids(ig, vp=c(startNode, startNodeUnvisitedNeighbors[z]))] = 1
        lbls = rep("", length(E(ig)$weight))
        lbls[get.edge.ids(ig, vp=c(startNode, startNodeUnvisitedNeighbors[z]))] = round(inherited.probability/2, 3)
        png(sprintf("%s/diffusionEventMovie%d.png", output_dir, .GlobalEnv$imgNum), 500, 500)
        plot.igraph(ig, layout=cbind(V(ig)$x, V(ig)$y), vertex.color=V(ig)$color,
                    vertex.label=V(ig)$label, vertex.label.dist = 3, edge.label = lbls, edge.width=5*abs(E(ig)$weight),
                    mark.col="black", mark.border = "black", mark.groups = startNode)
        title(sprintf("Diffuse %.2f from %s at recursion level %d.", p1, startNode, recursion_level), cex.main=1)
        legend("bottomright", legend=c("Visited", "Unvisited"), fill=c("red", "blue"))
        dev.off()
        .GlobalEnv$imgNum = .GlobalEnv$imgNum + 1

        G = graph.diffuseP1Movie(inherited.probability/2, startNodeUnvisitedNeighbors[z], G,
                                 c(visitedNodes, startNodeUnvisitedNeighbors[z]), ig, recursion_level+1, output_dir)
      }
      z = z + 1
    }
    V(ig)$color = rep("blue", length(G))
    V(ig)$color[which(V(ig)$name %in% visitedNodes)] = "red"
    V(ig)$label = sprintf("%s:%.2f", V(ig)$name, G)
    png(sprintf("%s/diffusionEventMovie%d.png", output_dir, .GlobalEnv$imgNum), 500, 500)
    plot.igraph(ig, layout=cbind(V(ig)$x, V(ig)$y), vertex.color=V(ig)$color,
                vertex.label=V(ig)$label, vertex.label.dist = 3, edge.width=5*abs(E(ig)$weight),
                mark.col="black", mark.border = "black", mark.groups = startNode)
    title(sprintf("Diffuse %.2f from %s at recursion level %d.", p1, startNode, recursion_level), cex.main=1)
    legend("bottomright", legend=c("Visited", "Unvisited"), fill=c("red", "blue"))
    dev.off()
    .GlobalEnv$imgNum=.GlobalEnv$imgNum+1
  } else {
    #print("startNode is stranded with its visited neighbors, or is a singleton. Diffuse p1 uniformly amongst all unvisited nodes")
    t = 1
    while (t <= length(G)) {
      if (!(names(G[t]) %in% visitedNodes)) {
        G[[t]] = G[[t]] + p1/(length(G) - length(visitedNodes))
      }
      t = t + 1
    }
  }
  return(G)
}


cat("Uvažam grafe...\n")

pdf("slike/grafi1.pdf", paper="a4r")

regije <- trajanjebrez$STATISTI.NA.REGIJA
regije[1] <- "Jugovzhodna\nSlovenija"
barplot(trajanjebrez[1:12,9], sub="statistična regija", ylab="trajanje bezposelnosti",
        main="Trajanje brezposlenosti po statističnih regijah v Sloveniji v letu 2014",
        col="lightblue", names.arg = regije, las = 2, cex.names=0.5, cex.axis=0.7)

dev.off()

pdf("slike/grafi2.pdf", paper="a4r")

regije <- trajanjebrez$STATISTI.NA.REGIJA
regije[1] <- "Jugovzhodna\nSlovenija"
barplot(brezstarost[1:12,7], sub="statistična regija", ylab="brezposelnost prebivalcev starejših od 55 let",
        main="Brezposelnost prebivalcev starejših od 55 let v letu 2014",
        col="pink", names.arg = regije, las = 2, cex.names=0.5, cex.axis=0.7)

dev.off()


print("insert number a")
a <- scan(what=numeric(0), nmax=1)
print("insert number b")
b <- scan(what=numeric(0), nmax=1)
if ( a < b ) {
  print("a is less than b")
} else if ( a > b ) {
  print("a is greater than b")
} else if ( a == b ) { # could be simply else of course...
  print("a and b are the same")
}


#' `nplot` using base graphics
#' @param edge.color.mix Proportion of the mixing.
#' @param edge.color.alpha Either a vector of length 1 or 2, or a matrix of
#' size `ecount(x)*2` with values in `[0,1]`. Alpha (transparency) levels (see
#' details)
#' @inheritParams nplot
#' @export
#' @return `nplot_base` returns a list with the following components:
#'
#' - `vertex.coords` A list of length `N` where each element describes the
#' geomtry of each vertex.
#' - `vertex.color` A vector of colors
#' - `vertex.frame.coords` Similar to `vertex.coords`, but for the frame.
#' - `vertex.frame.color` Similar to `vertex.color`, but for the frame.
#' - `edge.color` Vector of functions used to compute the edge colors.
#' - `edge.coords` Similar to `vertex.coords`, the points that describe each
#' edge.
#' - `edge.arrow.coords` A list of matrices describing the geometry of the
#' tip of the edges.
#' - `edge.width` A numeric vector with edges' widths.
#' - `xlim`, `ylim` Limits of the plot area.
#' @seealso [nplot]
#' @examples
#' # Same example as in nplot
#' library(igraph)
#' library(netplot)
#' set.seed(1)
#' x <- sample_smallworld(1, 200, 5, 0.03)
#'
#' nplot_base(x) # ala netplot (using base)
nplot_base <- function(
  x,
  layout              = igraph::layout_nicely(x),
  vertex.size         = igraph::degree(x, mode="in"),
  bg.col              = "transparent",
  vertex.nsides       = 15,
  vertex.color        = grDevices::hcl.colors(1),
  vertex.size.range   = c(.01, .03),
  vertex.frame.color  = grDevices::adjustcolor(vertex.color, red.f = .75, green.f = .75, blue.f = .75),
  vertex.rot          = 0,
  vertex.frame.prop   = .1,
  edge.width          = NULL,
  edge.width.range    = c(1, 2),
  edge.arrow.size     = NULL,
  edge.color          = NULL,
  edge.color.mix      = .5,
  edge.color.alpha    = c(.1, .5),
  edge.curvature      = pi/3,
  edge.line.lty       = "solid",
  edge.line.breaks    = 10,
  sample.edges        = 1,
  skip.vertex         = FALSE,
  skip.edges          = FALSE,
  skip.arrows         = skip.edges,
  add                 = FALSE,
  zero.margins        = TRUE
) {

  # Computing colors
  if (!length(vertex.color)) {
    vertex.color <- length(table(igraph::degree(x, mode = "in")))
    vertex.color <- grDevices::hcl.colors(vertex.color)
    vertex.color <- vertex.color[
      as.factor(igraph::degree(x, mode = "in"))
      ]
  }

  # # Creating the window
  if (zero.margins) {
    oldpar <- graphics::par(mai=rep(0, 4))
    on.exit(graphics::par(oldpar))
  }

  if (!add)
    graphics::plot.new()

  # Adjusting layout to fit the device
  layout <- fit_coords_to_dev(layout)

  # Plotting
  xlim <- range(layout[,1])
  ylim <- range(layout[,2])
  graphics::plot.window(xlim, ylim, asp=1, new=FALSE)

  # Adding rectangle
  if (length(bg.col)) {
    usr <- graphics::par("usr")
    rect(
      usr[1], usr[3], usr[2], usr[4],
      col = bg.col,
      border = grDevices::adjustcolor(bg.col, red.f = 1.5, green.f = 1.5, blue.f = 1.5))
  }

  # Rescaling size
  vertex.size <- rescale_size(vertex.size, rel = vertex.size.range)

  # Computing shapes -----------------------------------------------------------
  E <- igraph::as_edgelist(x, names = FALSE)

  if (sample.edges < 1) {
    sample.edges <- sample.int(nrow(E), floor(nrow(E)*sample.edges))
    E <- E[sample.edges, , drop=FALSE]
  }

  # Weights
  if (!length(edge.width))
    edge.width <- rep(1.0, igraph::ecount(x))

  # Rescaling edges
  edge.width <- rescale_size(edge.width/max(edge.width, na.rm=TRUE), rel = edge.width.range)

  if (!length(edge.arrow.size))
    edge.arrow.size <- vertex.size[E[,1]]/1.5
  else if (length(edge.arrow.size) == 1L)
    edge.arrow.size <- rep(edge.arrow.size, nrow(E))

  # Calculating arrow adjustment
  arrow.size.adj <- edge.arrow.size*cos(pi/6)/(
    cos(pi/6) + cos(pi - pi/6 - pi/1.5)
  )/cos(pi/6)

  # Making space for the arrow and edges coordinates
  edge.coords <- vector("list", nrow(E))
  edge.arrow.coords <- vector("list", length(edge.coords))

  if (length(edge.curvature) == 1)
    edge.curvature <- rep(edge.curvature, length(edge.coords))

  if (length(edge.line.breaks) == 1)
    edge.line.breaks <- rep(edge.line.breaks, length(edge.coords))

  for (e in 1:nrow(E)) {

    i <- E[e,1]
    j <- E[e,2]

    # Calculating edges coordinates
    edge.coords[[e]] <- arc(
      layout[i,], layout[j,],
      radii = vertex.size[c(i,j)] + c(0, arrow.size.adj[e]),
      alpha = edge.curvature[e],
      n     = edge.line.breaks[e]
    )

    # Computing arrow
    alpha1 <- attr(edge.coords[[e]], "alpha1")
    edge.arrow.coords[[e]] <- arrow_fancy(
      x = edge.coords[[e]][nrow(edge.coords[[e]]),1:2] +
        arrow.size.adj[e]*c(cos(alpha1), sin(alpha1)),
      alpha = alpha1,
      l     = edge.arrow.size[e]
    )

  }

  # Edges ----------------------------------------------------------------------
  if (!length(edge.color.mix))
    edge.color.mix <- rep(.5, length(edge.coords))
  else if (length(edge.color.mix) == 1)
    edge.color.mix <- rep(edge.color.mix, length(edge.coords))

  if (!length(edge.line.lty))
    edge.line.lty <- rep(1L, length(edge.coords))
  else if (length(edge.line.lty) == 1)
    edge.line.lty <- rep(edge.line.lty, length(edge.coords))

  if (!length(edge.color.alpha))
    edge.color.alpha <- matrix(.5, nrow= length(edge.coords), ncol=2)
  else if (length(edge.color.alpha) <= 2)
    edge.color.alpha <- matrix(edge.color.alpha, nrow= length(edge.coords), ncol=2, byrow = TRUE)

  # Nodes ----------------------------------------------------------------------
  if (length(vertex.color) == 1)
    vertex.color <- rep(vertex.color, nrow(layout))

  if (!length(vertex.frame.color))
    vertex.frame.color <- adjustcolor(vertex.color, red.f = .75, blue.f = .75, green.f = .75)

  if (length(vertex.nsides) == 1)
    vertex.nsides <- rep(vertex.nsides, nrow(layout))

  if (length(vertex.rot) == 1)
    vertex.rot <- rep(vertex.rot, nrow(layout))

  if (length(vertex.frame.prop) == 1)
    vertex.frame.prop <- rep(vertex.frame.prop, nrow(layout))

  edge.color <- vector("list", length(edge.coords))

  for (i in seq_along(edge.coords)) {

    if (!length(edge.coords[[i]]))
      next

    # Not plotting self (for now)
    if (E[i,1] == E[i, 2])
      next

    # Computing edge color
    col <- edge_color_mixer(
      i     = E[i, 1],
      j     = E[i, 2],
      vcols = vertex.color,
      p     = edge.color.mix[i],
      alpha = 1
    )

    edge.color[[i]] <- colorRamp2(
      c(
        adjustcolor(col, alpha.f = edge.color.alpha[i,1]),
        adjustcolor(col, alpha.f = edge.color.alpha[i,2])
      ), alpha = TRUE)

    # Drawing lines
    if (!skip.edges) {
      segments_gradient(
        edge.coords[[i]], lwd= edge.width[i],
        col = edge.color[[i]],
        lty = edge.line.lty[i]
      )
    }

    if (!skip.arrows) {
      # Drawing arrows
      graphics::polygon(
        edge.arrow.coords[[i]],
        col    = col,
        border = col,
        lwd    = edge.width[i]
      )
    }

  }

  vertex.frame.prop <- 1 - vertex.frame.prop

  vertex.coords <- vector("list", nrow(layout))
  vertex.frame.coords <- vector("list", nrow(layout))

  if (!skip.vertex)
    for (i in 1:nrow(layout)) {
      # Computing coordinates
      vertex.coords[[i]] <- npolygon(
        layout[i,1], layout[i,2],
        n = vertex.nsides[i],
        r = vertex.size[i]*vertex.frame.prop[i],
        vertex.rot[i]
      )
      vertex.frame.coords[[i]] <- piechart(
        1,
        origin = layout[i,],
        edges  = vertex.nsides[i],
        radius = vertex.size[i],
        doughnut = vertex.size[i]*vertex.frame.prop[i],
        rescale = FALSE,
        add     = TRUE,
        skip.plot.slices = TRUE
      )$slices[[1]]

      # Circle
      graphics::polygon(
        vertex.coords[[i]],
        col    = vertex.color[i],
        border = vertex.color[i],
        lwd=1
      )

      # Border
      graphics::polygon(
        vertex.frame.coords[[i]],
        col    = vertex.frame.color[i],
        border = vertex.frame.color[i],
        lwd=1
      )

    }

  invisible({
    list(
      vertex.coords       = vertex.coords,
      vertex.color        = vertex.color,
      vertex.frame.coords = vertex.frame.coords,
      vertex.frame.color  = vertex.frame.color,
      edge.color         = edge.color,
      edge.coords        = edge.coords,
      edge.arrow.coords  = edge.arrow.coords,
      edge.width         = edge.width,
      xlim                = xlim,
      ylim                = ylim
    )
  })

}


for ( i in 0:3 ) {
  print(ackermann(i, 4))
}


########################### BayesKin ###########################
## Bayesian estimates of rigid body kinematics
## Andy Pohl
## UofC - Faculty of Kinesiology

## Written by: Andy Pohl
## UofC - Faculty of Kinesiology
## June-Dec 2020
## Revision 1: May 2020
################################################################

##################### SupplementE.r  ###################
## Performs additional analysis examining the robustness of Bayesian models to
## increases in measurement noise
################################################################

## Preliminaries
rm(list = ls())

WORKING_DIR = "/media/data/ActiveProjects/P01_BayesianKinematics/PublishedCode/BayesKin/src/SupplementE" # Replace with appropriate location of working directory on local PC
SAVE_MDL = TRUE # assume save
INIT_TYPE = 'true_vals' # either 'true_vals', 'ls_est', 'random
NITS = 1000 # number of iterations.

setwd(WORKING_DIR)

# External libraries
library('dplyr')
library('latex2exp')

source('./library.r') # Retrieve function library

set.seed(1)  # Set seed for reproducibility

########################### Section A  #########################
## Specify simulation parameters
################################################################

## 1) Specify parameters
n.links = 1                 # Number of links.
seg.length = c(0.45)        # Length of segment specified in m. NB: Pataky pg 2.
r_true = c(0.07, 0.03)      # Origin location in m.
theta_true = c(-55)         # Rotation angle in deg. NB: specified to avoid 0/360 issue
# and mirroring solutions.
sigma_true = c(0.1, 1.5, 5, 10, 20,40)*(1/1000) # Measurement Noise in m
links = list(gen_link(seg.length = seg.length[1],
                      plate.center = 0.7*seg.length[1])) # Link geometry

########################### Section B  #########################
## Run simulations
    # run NITS iterations per sigma level
################################################################
results = matrix(NA, nrow = length(sigma_true)*NITS*5, ncol = 7)
row_idx =1
for(i in 1:length(sigma_true)){
    true_vals = list(r_true = r_true, theta_true = theta_true, sigma_true = sigma_true[i])

    # Generate posture
    posture = gen_posture(links, r = true_vals$r_true, theta = true_vals$theta_true)
    seeds = 1:NITS # Generate seed values for each iteration

    for(j in 1:NITS){
        seed = seeds[j]
        set.seed(seed)
        print(sprintf("--------------------Iteration %.0f of %.0f  -  seed = %.0f---------------------\n",j, NITS, seed))
        # gen obs
        y = gen_obs(posture, true_vals$sigma_true)
        #plot_system(posture = posture, y=y)
        print("Compute LS solution.")
        LS_result = LS_soln(y, links,
                            inits = c(true_vals$r_true, true_vals$theta_true, true_vals$sigma_true),
                            init_type = 'true_vals')
        results[row_idx,] = c(true_vals$sigma_true, 1, seed, LS_result$r.hat[1], LS_result$r.hat[2], LS_result$theta.hat[1],LS_result$sigma.hat)
        row_idx = row_idx+1

        Bayes1_result = Bayes_soln(y=y,
                                   links = links,
                                   mdlfile = './BayesModel_vague1.jags', # Vague 1
                                   init_type = INIT_TYPE,
                                   true_vals = c(true_vals$r_true,true_vals$theta_true, true_vals$sigma_true),
                                   ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))
        Bayes1_result = summary(Bayes1_result$fit)
        results[row_idx,] = c(true_vals$sigma_true, 2, seed, Bayes1_result$statistics['r[1]',1], Bayes1_result$statistics['r[2]',1], Bayes1_result$statistics['theta',1],  Bayes1_result$statistics['sigma',1])
        row_idx = row_idx +1

        Bayes2_result = Bayes_soln(y=y,
                                   links = links,
                                   mdlfile = './BayesModel_vague2.jags', # Vague 2
                                   init_type = INIT_TYPE,
                                   true_vals = c(true_vals$r_true,true_vals$theta_true, true_vals$sigma_true),
                                   ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))
        Bayes2_result = summary(Bayes2_result$fit)
        results[row_idx,] = c(true_vals$sigma_true, 3, seed, Bayes2_result$statistics['r[1]',1], Bayes2_result$statistics['r[2]',1], Bayes2_result$statistics['theta',1],  Bayes2_result$statistics['sigma',1])
        row_idx = row_idx +1

        Bayes4_result = Bayes_soln(y=y,
                                   links = links,
                                   mdlfile = './BayesModel_p3.jags', # Weakly Informative
                                   init_type = INIT_TYPE,
                                   true_vals = c(true_vals$r_true,true_vals$theta_true, true_vals$sigma_true),
                                   ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))
        Bayes4_result = summary(Bayes4_result$fit)
        results[row_idx,] = c(true_vals$sigma_true, 4, seed, Bayes4_result$statistics['r[1]',1], Bayes4_result$statistics['r[2]',1], Bayes4_result$statistics['theta[1]',1],  Bayes4_result$statistics['sigma',1])
        row_idx = row_idx +1

        Bayes5_result = Bayes_soln(y=y,
                                   links = links,
                                   mdlfile = './BayesModel_p2.jags', # Informative
                                   init_type = INIT_TYPE,
                                   true_vals = c(true_vals$r_true,true_vals$theta_true, true_vals$sigma_true),
                                   ls_est = c(LS_result$r.hat, LS_result$theta.hat, LS_result$sigma.hat))

        Bayes5_result = summary(Bayes5_result$fit)
        results[row_idx,] = c(true_vals$sigma_true, 5, seed, Bayes5_result$statistics['r[1]',1], Bayes5_result$statistics['r[2]',1], Bayes5_result$statistics['theta',1],Bayes5_result$statistics['sigma',1])
        row_idx = row_idx +1

    }
}

if(SAVE_MDL){
    saveRDS(results, "./DeltaVarResults.rds")
}
results = readRDS('./DeltaVarResults.rds')

########################### Section C  #########################
## Process results and generate figures
################################################################
models = c('LS', 'Bayes Vague 1', "Bayes Vague 2",
           'Bayes Weakly Informative', 'Bayes Informative')

abs_error = matrix(NA, nrow = length(sigma_true)*length(models)*4, ncol = 6)
abs_error = data.frame(abs_error)
names(abs_error) = c('sigma', 'Model', 'Parameter', 'lwr', 'med', 'upr')

perf = matrix(NA, nrow = 3*length(sigma_true)*length(models), ncol = 4)
perf = data.frame(perf)
names(perf) = c('sigma', 'Model', 'Parameter', 'Perf')
row_idx = 1
row_idx2 = 1
for(i in 1:length(sigma_true)){
    sigma_result = results[results[,1]==sigma_true[i],]
    for(j in 1:length(models)){ # Summarize abs error of each model
        mdl_result = sigma_result[sigma_result[,2] == j,]
        abs_error[row_idx,1] = unique(mdl_result[,1])
        abs_error[row_idx,2] = unique(mdl_result[,2])
        abs_error[row_idx,3] = 'rx'
        abs_error[row_idx, 4:6] = quantile(abs(mdl_result[,4] - r_true[1]), probs = c(0.025, 0.5, 0.975))*1000
        row_idx = row_idx+1

        abs_error[row_idx,1] = unique(mdl_result[,1])
        abs_error[row_idx,2] = unique(mdl_result[,2])
        abs_error[row_idx,3] = 'ry'
        abs_error[row_idx, 4:6] = quantile(abs(mdl_result[,5] - r_true[2]), probs = c(0.025, 0.5, 0.975))*1000
        row_idx = row_idx+1

        abs_error[row_idx,1] = unique(mdl_result[,1])
        abs_error[row_idx,2] = unique(mdl_result[,2])
        abs_error[row_idx,3] = 'theta1'
        abs_error[row_idx, 4:6] = quantile(abs(mdl_result[,6] - theta_true[1]), probs = c(0.025, 0.5, 0.975))
        row_idx = row_idx+1

        abs_error[row_idx,1] = unique(mdl_result[,1])
        abs_error[row_idx,2] = unique(mdl_result[,2])
        abs_error[row_idx,3] = 'sigma'
        abs_error[row_idx, 4:6] = quantile(abs(mdl_result[,7] - sigma_true[i]), probs = c(0.025, 0.5, 0.975))*1000
        row_idx = row_idx +1

        if(j >=2){ # Compute performance of Bayes vs LS.
            perf[row_idx2,1] = unique(mdl_result[,1])
            perf[row_idx2,2] = unique(mdl_result[,2])
            perf[row_idx2,3] = 'rx'
            perf[row_idx2,4] = mean(abs(mdl_result[,4] - r_true[1]) < abs(sigma_result[sigma_result[,2] == 1,4] - r_true[1]))
            row_idx2 = row_idx2 +1

            perf[row_idx2,1] = unique(mdl_result[,1])
            perf[row_idx2,2] = unique(mdl_result[,2])
            perf[row_idx2,3] = 'ry'
            perf[row_idx2,4] = mean(abs(mdl_result[,5] - r_true[2]) < abs(sigma_result[sigma_result[,2] == 1,5] - r_true[2]))
            row_idx2 = row_idx2 +1

            perf[row_idx2,1] = unique(mdl_result[,1])
            perf[row_idx2,2] = unique(mdl_result[,2])
            perf[row_idx2,3] = 'theta1'
            perf[row_idx2,4] = mean(abs(mdl_result[,6] - theta_true[1]) < abs(sigma_result[sigma_result[,2] == 1,6] - theta_true[1]))
            row_idx2 = row_idx2 +1

            perf[row_idx2,1] = unique(mdl_result[,1])
            perf[row_idx2,2] = unique(mdl_result[,2])
            perf[row_idx2,3] = 'sigma'
            perf[row_idx2,4] = mean(abs(mdl_result[,7] - sigma_true[i]) < abs(sigma_result[sigma_result[,2] == 1,7] - sigma_true[i]))
            row_idx2 = row_idx2 +1
        }
    }
}
abs_error$sigma = abs_error$sigma*1000
perf$sigma = perf$sigma*1000

########################### Section D  #########################
## Generate figures and tables
################################################################

# Color scheme
colors = list(grey = rgb(97/255, 97/255,97/255, 0.2),
              orange = rgb(241/255, 136/255,5/255, 1),
              blue = rgb(18/255, 78/255,120/255,  0.2),
              light_blue = rgb(93/255, 173/255,226/255,  0.2),
              red = rgb(162/255, 0/255,33/255, 0.2),
              green = rgb(76/255, 159/255, 112/255, 0.2),
              purple = rgb(217/255, 187/255, 249/255, 0.2),
              pink = rgb(217/255, 3/255, 104/255, 0.2))

colors2 = list(grey = rgb(97/255, 97/255,97/255, 0.2),
               orange = rgb(241/255, 136/255,5/255, 1),
               blue = rgb(18/255, 78/255,120/255, 1),
               light_blue = rgb(93/255, 173/255,226/255,  1),
               red = rgb(162/255, 0/255,33/255, 1),
               green = rgb(76/255, 159/255, 112/255, 1),
               purple = rgb(217/255, 187/255, 249/255, 1),
               pink = rgb(217/255, 3/255, 104/255, 1))
point_cols = list(colors$pink, colors$blue,colors$light_blue, colors$purple,colors$green)
point_cols2 = list(colors2$pink, colors2$blue,colors2$light_blue, colors2$purple,colors2$green)

## -----------------------------------------------------------------------------
# Figure 1 'Line' plot of absolute error accross strain.
## -----------------------------------------------------------------------------

ylabs = c(TeX("Absolute Error $\\hat{r}_x \\, (mm)$"), TeX("Absolute Error $\\hat{r}_y \\, (mm)$"), TeX("Absolute Error $\\hat{\\theta}_1 \\, (deg)$"), TeX("Absolute Error $\\hat{\\sigma} \\, (mm)$"))
titles = c(TeX("$r_x$"), TeX("$r_y$"), TeX('$\\theta_1'), TeX("$\\sigma$"))
titles = c("(a)","(b)",'(c)',"(d)")

parameters = c('rx', 'ry', 'theta1', 'sigma')
ylims = list(c(0, 250), c(0,250), c(0, 60), c(0, 40))
# j = 1:4 parameters
# i = 1:5 models

par(mfrow=c(1,4))
for(j in 1:4){
    for(i in 1:5){
        parm_abs_error = abs_error %>% filter(Parameter ==parameters[j])

        mdl_abs_error = parm_abs_error %>% filter(Model ==i)
        jitter = (2-(5-i)) * 0.05*mdl_abs_error[,1]

        plot_col2 = point_cols2[[i]]
        plot_col1 = point_cols[[i]]
        if(i ==1){
            plot(mdl_abs_error$sigma + jitter, mdl_abs_error$med,type = 'b', pch = 16, col =plot_col2,
                 xlab = TeX("Noise Level: $\\sigma \\, (mm)$"), ylab = ylabs[j], bty='n',
                 xlim = c(-0.02, 50), ylim = ylims[[j]],
                 xaxt ='n')
            segments(x0=mdl_abs_error$sigma + jitter, y0 =  mdl_abs_error$lwr, x1 = mdl_abs_error$sigma + jitter, y1 = mdl_abs_error$upr, lty = 3, col = plot_col2)
            axis(side = 1, at = (sigma_true*1000), as.character(sigma_true*1000), las=2)
        }else{
            lines(mdl_abs_error$sigma + jitter, mdl_abs_error$med,type = 'b', pch = 16, col =plot_col2)
            segments(x0=mdl_abs_error$sigma + jitter, y0 =  mdl_abs_error$lwr, x1 = mdl_abs_error$sigma + jitter, y1 = mdl_abs_error$upr, lty = 3, col = plot_col2)

        }
        title(titles[j], font.main=1)

    }
}
legend(0, 40, legend = models[1:5],
       col = c(point_cols2[[1]],point_cols2[[2]], point_cols2[[3]], point_cols2[[4]], point_cols2[[5]]),
       lty = 1, bty='n')

## -----------------------------------------------------------------------------
# Figure 2 'Line' plot of proportion of sims where Bayes had < error than LS
## -----------------------------------------------------------------------------

titles = c(TeX("(a) \t $r_x$"),TeX("(b) \t $r_y$"),TeX('(c) \t $\\theta_1$'),TeX("(d) \t $\\sigma$"))
par(mfrow=c(1,4))
for(j in 1:4){
    for(i in 2:5){
        parm_perf = perf %>% filter(Parameter ==parameters[j])
        mdl_parm_perf = parm_perf %>% filter(Model ==i)
        jitter = 0

        plot_col2 = point_cols2[[i]]
        if(i ==2){
            plot(mdl_parm_perf$sigma + jitter, mdl_parm_perf$Perf,type = 'b', pch = 16, col =plot_col2,
                 xlab = TeX("Noise Level: $\\sigma \\, (mm)$"), ylab = "Proportion of Simulations", bty='n',
                 xlim = c(-0.02, 50), ylim = c(0.4,1),
                 xaxt ='n')
            axis(side = 1, at = (sigma_true*1000), as.character(sigma_true*1000), las=2)
        }else{
            lines(mdl_parm_perf$sigma + jitter, mdl_parm_perf$Perf,type = 'b', pch = 16, col =plot_col2)

        }
        title(titles[j], main.font=1)

    }
}
legend(0, 0.5, legend = models[2:5],
       col = c(point_cols2[[2]], point_cols2[[3]], point_cols2[[4]], point_cols2[[5]]),
       lty = 1, bty='n')

## -----------------------------------------------------------------------------
# Figure 3 Scatter Plot of LS estimator vs Bayes estimator
## -----------------------------------------------------------------------------
axis_lims = list(c(-0.2*1000, 0.5*1000), c(-0.5*1000, 0.2*1000), c(-150,100), c(0*1000, 0.12*1000))
true_vals_vec = c(r_true*1000, theta_true, sigma_true[6]*1000)
results_40 = results[results[,1]==40/1000,] # This can be changed to explore other noise levels
results_40[,c(4,5,7)] = results_40[,c(4,5,7)]*1000
ylabs = c("Vague 1", "Vague 2", "Weakly Informative", "Informative")
titles = c(TeX("$r_x \\, (mm)$"), TeX("$r_y \\, (mm)$"), TeX('$\\theta_1 \\, (deg)'), TeX("$\\sigma \\, (mm)$"))

par(mfrow=c(4,4), mai = c(0.6, 0.6, 0.0, 0))
for(i in 2:5){
    for(j in 1:4){
        ls_result = results_40[results_40[,2]==1, 3+j]
        mdl_result = results_40[results_40[,2]==i, 3+j]
        b_ls = sqrt((mdl_result-true_vals_vec[j])^2) - sqrt((ls_result - true_vals_vec[j])^2)

        b_ls = ifelse(b_ls<0, 1,2)
        cols = list(rgb(52/255, 152/255, 219/255, 0.2),
                    colors$pink)
        mycol = rep("", length(b_ls))
        for(ii in 1:length(b_ls)){
            mycol[ii] = cols[[b_ls[ii]]]
        }
        if(j ==1 & i ==5){
            plot(ls_result, mdl_result, pch = 16, col = mycol,
                 #asp = 1,
                 xlim = axis_lims[[j]], ylim = axis_lims[[j]],
                 xlab = "LS est",
                 ylab = ylabs[i-1],
                 bty='n')
        }else if (j >1 & i ==5 ){
            plot(ls_result, mdl_result, pch = 16, col = mycol,
                 #asp = 1,
                 xlim = axis_lims[[j]], ylim = axis_lims[[j]],
                 xlab = "LS est",
                 ylab = NA,
                 bty='n')
        }else if(j==1 & i < 5){
            plot(ls_result, mdl_result, pch = 16, col = mycol,
                 #asp = 1,
                 xlim = axis_lims[[j]], ylim = axis_lims[[j]],
                 xlab = NA,
                 ylab = ylabs[i-1],
                 bty='n')
        }else{
            plot(ls_result, mdl_result, pch = 16, col = mycol,
                 #asp = 1,
                 xlim = axis_lims[[j]], ylim = axis_lims[[j]],
                 xlab = NA, ylab = NA,
                 bty='n')
        }
        if(i ==2){
            title(titles[j], line =-1)
        }

        abline(0,1, col = colors$orange)
        points(true_vals_vec[j],true_vals_vec[j], pch=18, cex = 2,col = colors2$orange)

    }
}

########################### Section E  #########################
## Additional Figures not referenced in supplement
################################################################

# Scatter plot of error distribution for each model/noise level
ylabs = list(r1=TeX("$r_1 \\,  (mm)$"), r2=TeX("$r_2  \\, (mm)$"), theta1=TeX("$\\theta_1 \\, (^o)$"),
             sigma=TeX("$\\sigma \\, (mm)$"))
ylims = list(c(-0.1,0.6), c(-0.6, 0.4), c(-180, 60), c(-0.03, 0.12))

par(mfrow = c(4, 6),mai = c(0, 0.6, 0.0, 0), oma=c(0,0,0,0))
for(j in 1:4){
    for(i in 1:6){
        # i= 1 # noise level (1:6)
        # j = 1 # parameter (1:4)
        true_val_tmp = c(r_true, theta_true, sigma_true[i])

        sigma_results = results[(results[,1]==sigma_true[i]), ]
        plot_col = rep("", nrow(sigma_results))
        for(ii in 1:nrow(sigma_results)){
            plot_col[ii] = point_cols[[sigma_results[ii,2]]]
        }

        if(i != 1){
            plot(sigma_results[,2]+rnorm(nrow(sigma_results), 0, 0.1), sigma_results[,3+j],
                 pch = 16, col = plot_col,
                 ylab = NA, yaxt = 'n',
                 ylim =ylims[[j]],
                 xlab = NA, bty='n', xaxt = 'n')
        }else{
            plot(sigma_results[,2]+rnorm(nrow(sigma_results), 0, 0.1), sigma_results[,3+j],
                 pch = 16, col = plot_col,
                 ylab = ylabs[[j]],
                 ylim =ylims[[j]],
                 xlab = NA, bty='n', xaxt = 'n')
        }
        abline(h = true_val_tmp[j], col = colors$orange)

        if(j ==1){
            title(TeX(sprintf("$\\sigma$ = %.1fmm$", c(sigma_true[i]*1000))), line = -2)
        }
    }
}


library("ggplot2")
library("reshape2")
library("RColorBrewer")
#
# #  rm(list=ls())
# # load("data/clim.R")
# #  map<-cru_raster_10min_window$val[,,2]
# #  Longitude<<-cru_raster_10min_window$lon
# #  Latitude<<-cru_raster_10min_window$lat
#
# #
# # bitmap("test.jpeg",pointsize=19,width=297,height=210,res=120,type="jpeg",unit="mm")
# #  width<-par()$fin[1]
# # mar<-par("mar")
# # mar[1]<-5.1#south
# # mar[2]<-4.1#west
# # mar[3]<-4.1#north
# # mar[4]<-6.1#east
# # par("mar"=mar)
# # image(Longitude,Latitude,map)
# # title("Monthly Mean Surface Temperature of  [BCC-CSM1-1]")
# # #  par(usr=c(0,1,0,1))
# # # par(oldpar)
# # width<-par()$fin[1]
# # print(width)
# # mar[2]<-width+mar[2]+mar[4]/3#west
# # mar[4]<-mar[4]/3
# #   current_mai<-par("mai")
# # par(new=TRUE, plt=c(0,1,0,1),
# #  	  mai=c(current_mai[1], par("fin")[1]-par("mai")[4]+0.1,current_mai[3],current_mai[4]-0.1),
# #  	  usr=c(0,1,0,1))#,mgp = c(0.1, 0.3, 0))#,cex.axis=0.35)
# #
# # #
# # # par(new=TRUE, plt=c(0,1,0,1),mar=mar, usr=c(0,1,0,1))
# #
# # # par("mar"=mar)
# # # print(par()$mar)
# #
# #
# #
# #  image(matrix(c(1,10),1,10))
# #  title("x")
# # #  par(new=TRUE, mar=c(0,0,0,0))
# # #   image(matrix(c(1,10),1,10))
# #   dev.off()
# #
#
#
#
#   nRow <- 9
# nCol <- 16
#
# myData <- matrix(rnorm(nRow * nCol), ncol = nCol)
# rownames(myData) <- letters[1:nRow]
# colnames(myData) <- LETTERS[1:nCol]
#
# # Replace with numbers that actually have a relationship:
# for(ii in 2:ncol(myData)){ myData[, ii] <- myData[, ii-1] + rnorm(nrow(myData)) }
# for(ii in 2:nrow(myData)){ myData[ii, ] <- myData[ii-1, ] + rnorm(ncol(myData)) }
#
# # For melt() to work seamlessly, myData has to be a matrix.
# longData <- melt(myData)
# head(longData, 20)
#
# # Optionally, reorder both the row and column variables in any order
# # Here, they are sorted by mean value
# longData$Var1 <- factor(longData$Var1, names(sort(with(longData, by(value, Var1, mean)))))
# longData$Var2 <- factor(longData$Var2, names(sort(with(longData, by(value, Var2, mean)))))
#
# # Define palette
# myPalette <- colorRampPalette(rev(brewer.pal(11, "Spectral")), space="Lab")
#
# zp1 <- ggplot(longData,
# aes(x = Var2, y = Var1, fill = value))
# zp1 <- zp1 + geom_tile()
#  zp1 <- zp1 + scale_fill_gradientn(colours = myPalette(100))
#  zp1 <- zp1 + scale_x_discrete(expand = c(0, 0))
#  zp1 <- zp1 + scale_y_discrete(expand = c(0, 0))
#  zp1 <- zp1 + coord_equal()
#  zp1 <- zp1 + theme_bw()
# # print(zp1) # Your plot will look different, depending on the seed


\docType{data}
\name{atmosfer}
\alias{atmosfer}
\title{Atmosferik veriler}
\format{41.472 satır ve 11 sütundan oluşan bir tibble
\describe{
\item{enlem}{Ölçüm noktası. 113,8 - 56,2 Batı boylamları ve 36,2 Kuzey - 21,2 Güney enlemleri arasında, eşit aralıklı 24 x 24 mekansal grid}
\item{boylam}{Ölçüm noktası. 113,8 - 56,2 Batı boylamları ve 36,2 Kuzey - 21,2 Güney enlemleri arasında, eşit aralıklı 24 x 24 mekansal grid}
\item{yıl}{Ocak 1995'ten Aralık 2000'e kadar, birer ay ara ile 72 gözlem}
\item{ay}{Ocak 1995'ten Aralık 2000'e kadar, birer ay ara ile 72 gözlem}
\item{yüzey_sıcaklığı}{Açık gökyüzü koşullarında dünya yüzeyinden yayılan enerjiye dayalı Kelvin cinsinden aylık ortalama yüzey sıcaklığı}
\item{sıcaklık}{Dünya yüzeyine yakın havanın Kelvin cinsinden aylık ortalama sıcaklığı}
\item{basınç}{Dünya yüzeyinde belirli bir konumdaki aylık ortalama atmosferik yüzey basıncı (mbar)}
\item{ozon}{Ortalama Ozon Bolluğu: Atmosferik kolondaki, Dobson cinsinden aylık ortalama toplam ozon miktarı}
\item{alçak_bulut}{Ortalama Alçak Bulut Örtüsü: Bulut tepe basıncı 680 mbar'dan fazla veya kabaca 3,24 km'den az bulutlarla kaplı gökyüzünün aylık ortalama yüzdesi}
\item{orta_bulut}{Ortalama Orta Bulut Örtüsü: Bulut tepe basıncı 440 - 680 mbar arasında veya kabaca 3,24'ten 6,5 km'ye kadar bulutlarla kaplı gökyüzünün aylık ortalama yüzdesi}
\item{yüksek_bulut}{Ortalama Yüksek Bulut Örtüsü: Bulut tepe basıncı 440 mbar'a eşit ya da daha az veya kabaca 6.5 km'den daha fazla bulutlarla kaplı gökyüzünün aylık ortalama yüzdesi}
}}
\usage{atmosfer}
\description{Atmosferik veriler.}
\seealso{\code{\link[nasaweather]{atmos}}}
\keyword{datasets}


# library(TwoSampleMR)
library(devtools)
load_all()
toggle_api("release")
a <- extract_instruments(300)
b <- extract_outcome_data(a$SNP, 7)
dat <- harmonise_data(a,b)
o1 <- dat_to_MRInput(dat, get_correlations=FALSE)
o2 <- dat_to_MRInput(dat, get_correlations=TRUE)

MendelianRandomization::mr_ivw(o1[[1]])
MendelianRandomization::mr_ivw(o2[[1]])


#!/usr/bin/env Rscript

library(readr)
library(lmerTest)
library(car)
library(psych)
library(scales)

speed_data <- read_csv('data.csv')

#calculate reading speed in WPM
speed_data$speed <- speed_data$num_words/(speed_data$adjust_rt/60000)

#remove retake participants
speed_data <- subset(speed_data, retake != 1)

#remove outliers
iqr = IQR(speed_data[speed_data$dyslexia_bin == 0,]$speed,na.rm=TRUE)
cutoff_high = median(speed_data$speed) +3*iqr #3*iqr=645, cutoff_high = 928

#-------remove trials based on speed-------
result_analysis <- speed_data[! speed_data$speed > cutoff_high, ]
result_analysis <- result_analysis[ ! result_analysis$speed < 10,]

#-------remove smartphone users-------
length(unique(subset(result_analysis$uuid, result_analysis$device=='smartphone')))
#remove 64 smartphone users, 363 trials
result_analysis <- result_analysis[! result_analysis$device == 'smartphone',]

#-------remove trials based on comprehension < 2/3-------
result_analysis <- result_analysis[ ! result_analysis$correct_rate < .6,]
#remove 111 trials

result_analysis$log_speed <- log(result_analysis$speed)

#dyslexia in three groups
model <- lmer(log_speed ~ img_width + num_words + page_condition*as.factor(dyslexia) + age + english_native + (1 | uuid), data = result_analysis)
AIC(model)
summary(model)


pdf_file<-"pdf/timeseries_seasonal_minmax_overlay.pdf"
cairo_pdf(bg="grey98", pdf_file,width=14,height=7)

par(omi=c(0.25,0,0.75,0.25),mai=c(0.5,2,0.5,2),family="Lato Light",las=1)

# Import data and prepare chart

library(gdata)
myData<-read.xls("myData/Climate2.xlsx", encoding="latin1")
myLines<-c(-5,0,5,10,15,20,25,30)
attach(myData)

# Create chart and other elements

myT1<-barplot(t(cbind(NY_min,NY_max-NY_min)),col=c("white","coral3"),border=NA,ylim=c(-5,35),axes=F,axisnames=F)
myT2<-barplot(t(cbind(MAJ_min,MAJ_max-MAJ_min)),col=c("white","cornflowerblue"),border=NA,add=T,axes=F,names.arg=Month)
axis(2,at=myLines,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
abline(h=myLines,col="white",lwd=2)
abline(v=seq(2.5,28.8,by=2.4),col="grey")
text(-0.95,34,"Degrees Celsius",xpd=T,cex=0.8)
legend(34,25,c("New York","Majorca"),col=c("coral3","cornflowerblue"),pch=15,bty="n",xjust=1,cex=1.5,pt.cex=1.5,xpd=T)

# Titling

mtext(side=3,"Monthly average temperatures",cex=2.25,adj=0.1,family="Lato Black",outer=T)
mtext(side=1,line=-1,"Source: Wikipedia",cex=1.25,adj=1,font=3,outer=T)
dev.off()


library('RColorBrewer')
library('mice', warn.conflicts = F, quietly = T)

# get path to source files from R environment
if(Sys.getenv('R_CLIMATE_TRACE_SHIPPING_HOME') == ''){
  stop('R_CLIMATE_TRACE_SHIPPING_HOME not in environment variables. Please add "R_CLIMATE_TRACE_SHIPPING_HOME=/path/to/r/climate/trace/shipping/repo" to the file .Renviron in your home directory. Read more about the .Renviron file here: https://support.rstudio.com/hc/en-us/articles/360047157094-Managing-R-with-Rprofile-Renviron-Rprofile-site-Renviron-site-rsession-conf-and-repos-conf')
}
CTHOME=Sys.getenv('R_CLIMATE_TRACE_SHIPPING_HOME')
source(paste(CTHOME,'/lib/load.r',sep=''))

# x <- load.generic.ship.data.and.metadata(paste(CTHOME,'/data/EU MRV data 18-19-20.csv',sep=''),imputation.method='none')
# # drop NA rows
# x <- x[!is.na(x$powerkwaux),]
# y <- x$powerkwaux # save true values

nimp <- 3 # n imputations
maxit.opts <- c(1,2,5,10,20) # max iterations

cormat <- matrix(0,nrow=nimp, ncol=length(maxit.opts)) # matrix of correlation performance
rownames(cormat) <- sprintf('nimp%03d',1:nimp)
colnames(cormat) <- sprintf('maxiter%03d',maxit.opts)

nreps <- 1 # n train/test splits
for(i in 1:nreps){
  # fraction training data
  train.frac <- 2/3
  train.ix <- sample(1:nrow(x),round(train.frac*nrow(x)))

  for(m in 1:length(maxit.opts)){
    maxit.i <- maxit.opts[m]

    # artificially set test samples' powerkwaux to NA
    x[-train.ix,'powerkwaux'] <- NA
    yfix <- mice(x[,colnames(x) != "IMO.Number"],m=nimp,maxit=maxit.i,method='rf')
    na.ix <- which(is.na(x[,'powerkwaux']))

    for(j in 1:nimp){
      cat(j,'')
      yhat <- y # will hold training and fixed values
      # get rowmeans using 100 random subsets of size j of the imputation columns
      for(k in 1:100){
        col.ix <- sample(nimp, j)
        yhat[na.ix] <- rowMeans(yfix$imp[['powerkwaux']][,col.ix,drop=F])

        cormat[j,m] <- cormat[j,m,drop=F] + cor(y[na.ix], yhat[na.ix])
      }
      cormat[j,m] <- cormat[j,m,drop=F] / 100
    }
    cat('\n')
  }
}

# plot
cols <- colorRampPalette(c('gray','blue'))(ncol(cormat))
plot(0,0,type='n',xlim=c(0,nimp),ylim=range(cormat))
for(i in 1:ncol(cormat)) lines(1:nimp, cormat[,i,drop=F],col=cols[i],lwd=2)
legend('topleft',colnames(cormat),col=cols[1:ncol(cormat)],lty=1,lwd=2)


#load libraries
library(tidyverse)
library(MASS)
library(epiDisplay)

#load data
atr_PCA <- read.csv("C:/Users/jagad/Desktop/ATR_PEDCA_manuscript/PCA_analysis_withSVI.csv",
                    sep= "," , header = TRUE )

#data formatting
fvar <- c( "Ground_cat", "Surface_cat")
atr_PCA[,fvar]<-lapply(atr_PCA [,fvar], factor)
nvar<- c("ca_count","Avg..E.Pl.Unemp","Avg..Pl.Sngprnt","Avg..Pl.Minority","Avg..E.Pl.Limeng")
atr_PCA[,nvar]<-sapply(atr_PCA[,nvar], as.numeric)
str(atr_PCA)

################### NEGATIVE BINOMIAL REG MODEL GROUND ATRAZINE AND PED CANCER ################
#negative binomial model with offset term to adjust for population density
fit_gr <- glm.nb(ca_count ~ Ground_cat+Avg..R.Pl.Themes+
                     offset(log(Total_Pead_pop)), data=atr_PCA)

#Figure 2

dat<- read.csv("C:/Users/jagad/Desktop/ATR_PEDCA_manuscript/PCA_SVI_estimates_fin.csv")

dat.fin<- filter(dat, Water.source %in% c("Ground","Surface"))

Model_order<-c("Unadjusted", "Adjusted_1", "Adjusted_2")
dat.fin$Variable <- factor(dat.fin$Variable, levels=c("Low", "Medium", "High"))

cbbPalette <- c("#999999", "#E69F00", "#56B4E9")

ggplot(dat.fin, aes(x = Variable, y = IRR, ymin = LL, ymax = UL))+
  facet_grid(cols = vars(Water.source))+
  geom_pointrange(aes(col = factor(Model, levels=Model_order)),
                  position=position_dodge(width=0.8),size = 1)+
  scale_y_continuous(breaks = seq(0, 13, 1),limits=c(0, 13))+
  geom_hline(yintercept = 1, linetype="longdash")+
  xlab("Atrazine groups")+
  ylab("Pediatric cancer - Incident Rate Ratio (IRR)")+
  scale_colour_manual(values=cbbPalette)+
    theme(plot.title = element_text(hjust = 0),
        plot.caption = element_text(hjust = 0),
        legend.title = element_blank(),
        text=element_text(size=15,  family="Arial Black"),
        axis.text = element_text(size = 15, family="Arial Black"),
        legend.text=element_text(size=15,  family="Arial Black"),
        strip.text.x = element_text(size=15,  family="Arial Black"),
        legend.position = "bottom",
        )

ggsave("C:/Users/jagad/Desktop/ATR_PEDCA_manuscript/fig3.tiff", units="in", width=12.5,
       height=8.5, dpi=300, compression = 'lzw')


# Author: Adam L. Rich
# Date:   November 18, 2011
# Description:
#
#   To analyze the Enhanced North American Benchmark Lexicon [ENABLE]
#

enable <- read.csv('./enable.csv', stringsAsFactors = FALSE, header = TRUE)[,1]

# Fix strings that get capitalized
enable[grepl('^true$', enable, ignore.case = TRUE)] <- 'true'
enable[grepl('^false$', enable, ignore.case = TRUE)] <- 'false'

word.length <- nchar(enable)

# Get count of words by length
word.length.table <- tapply(word.length, list(word.length), length)

letters         <- 'abcdefghijklmnopqrstuvwxyz'
vowels          <- 'aeiou'
consonants      <- 'bcdfghjklmnpqrstvwxyz'
vowels.y        <- 'aeiouy'
consonants.y    <- 'bcdfghjklmnpqrstvwxz'

c.letters       <- strsplit(letters, '')[[1]]
c.vowels        <- strsplit(vowels, '')[[1]]
c.consonants    <- strsplit(consonants, '')[[1]]
c.vowels.y      <- strsplit(vowels.y, '')[[1]]
c.consonants.y  <- strsplit(consonants.y, '')[[1]]

# build a data.frame of letter counts, etc.
tab <- rep(0L, length(enable) * 26)
dim(tab) <- c(length(enable), 26)

for(x in 1:length(enable)) {
  word <- enable[x]
  i.word <- as.integer(factor(strsplit(word, '')[[1]], levels = c.letters))
  tab[x,] <- tabulate(i.word, 26)
}

tab <- data.frame(tab)
names(tab) <- c.letters

words <- data.frame(name = enable, length = word.length, tab)

rm(enable, i.word, tab, word, word.length, x)

save.image(file = 'enable.RData')

# Find all dollar words
words.m <- as.matrix(words[, -c(1:2)])
scores <- rep(1:26, times = nrow(words.m))
scores.m <- t(matrix(scores, nrow = 26))
total <- rowSums(scores.m * words.m)

words$dollar.scores <- total

dollar.words <- words[words$dollar.scores == 100, ]


market.query = 'SELECT price_date AS Date,
        volume AS Volume,
        highPrice AS High,
        lowPrice AS Low,
        avgPrice AS Close
    FROM crest_markethistory
    WHERE itemid={itemid} AND
        regionid={regionid}
    ORDER BY Date DESC'
market.sqldata <- sqlQuery(emd, market.query)
odbcClose(emd)
n <- nrow(market.sqldata)
market.data <- data.table(market.sqldata[1:n-1,])
market.data$Open <- market.sqldata$Close[-1]
low_flag  = quantile(market.data$Low, .25) / 5
high_flag = quantile(market.data$High, .75) * 5
market.data$Low[market.data$Low<=low_flag] <-min(market.data$Open, market.data$Close)
market.data$High[market.data$High>=high_flag] <-max(market.data$Open, market.data$Close)
market.data.ts <- xts(
    market.data[, -1, with=F],
    order.by=market.data[,Date],
    period=7
)
png(
    '{plot_path}',
    width={img_width},
    height={img_height}
)
chartSeries(
    market.data.ts,
    name='{plot_title}',
    TA='{TA_args}',
    subset='{default_subset}'
)
dev.off()


# "City-specific GAM for Mid to higher severity"

# setting
```{r}

########################## Data setting
### Setting
rm(list=ls(all=TRUE))

library(data.table)
library(dplyr)
library(ggplot2)
library(car)
library(psych)
library(pROC)
library(epitools)
library(tableone)
library(caret)
library(tictoc)
library(Boruta)

library(doParallel)
detectCores(all.tests = FALSE, logical = TRUE)
cl <- makePSOCKcluster(27)
registerDoParallel(cl)

setwd(".")
set.seed(1234)

######################### Input data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

colnames(Data)
dim(Data)

Data[, table(TrainTest), ]

Data_train <- Data[TrainTest == "Train", , ] #*eligible
Data_train <- data.frame(Data_train)

Data_test <- Data[TrainTest == "Test", , ] #*eligible

######################## Prediction settings
# CV methods
CV_method <- "cv"
CV_number <- 5
Repeated_number <- 1
Tune_number <- 1

# formula
Form_temp <- formula(
	SeverityHigherMid ~
	offset(LogPopulation100000) +
	#Mean_income_city_2015 +
	#Green_area_percent +
	#Age_median_city +
	#Population_over_65_100000 +
	#SexRatioF +

	RainySeason +
	DifDateRain +
	holiday_flag +
	Hour +
	Month +

	precip1Hour +
	windSpeed_ms +
	DownwardSolarRadiation_kwm2 +
	relativeHumidity +
	temperature +
	temperature_past1d_max_diff +
	temperature_past1d_mean_diff +
	temperature_past1d_min_diff
)

### set seed
Size_n <- 13

Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )

Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct rfeControl object
rfe_control = rfeControl(
	functions = caretFuncs,
	allowParallel = TRUE,
	method = CV_method,
    number = CV_number,
	returnResamp = "final",
	seeds = Seeds_fix
	)

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

modelLookup("gamSpline")

# All city model for selecting feature variables and hyperparameter
gamSpline_city <- rfe(
	form = Form_temp,
	data = Data_train,
    method = "gamSpline",
	family = "poisson",

	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneLength = 10,

    sizes = 1:14, #ncol(Data),
    rfeControl = rfe_control
	)
summary(gamSpline_city)
gamSpline_city

gamSpline_city$optVariables
gamSpline_city$fit

saveRDS(gamSpline_city, paste("gamSpline_city_for_selecting_parameters_features.rds", sep = ""))

```

# city specific
```{r}

### City specific
Form_temp <- formula(
	SeverityHigherMid ~
	offset(LogPopulation100000) +
	Hour +
	RainySeason +
	Month +
	relativeHumidity +
	windSpeed_ms +
	temperature_past1d_min_diff +
	temperature_past1d_max_diff +
	precip1Hour +
	temperature +
	temperature_past1d_mean_diff +
	holiday_flag
	)

tune_params = expand.grid(
 	df = as.numeric(gamSpline_city$fit$bestTune)
)

tune_params

### set seed
Size_n <- 10

Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )

Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix
	)

HogeResults <- c()
HogeData <- c()

tic()
for(iii in Data$ID %>% unique() ){

# data
Data_train <- data.table(Data_train)
Data_train_city <- Data_train[ID == iii, , ] %>% data.frame()

Data_test <- data.table(Data_test)
Data_test_city <- Data_test[ID == iii, , ] %>% data.frame()

# city specific models
gamSpline_city <- train(
	form = Form_temp,
	data = Data_train_city,
    method = "gamSpline",
	family = "poisson",

	trControl = fit_control,
	metric = "RMSE",
	preProcess = c("center", "scale"),
	tuneLength = 10
	)

# save results
saveRDS(gamSpline_city, paste("gamSpline_city_", iii, ".rds", sep = ""))

HogeResults <- list(HogeResults, Model = iii, Results = gamSpline_city)

# make predictions
Data_train_city$Pred <- predict(gamSpline_city, Data_train_city)

Data_test_city$Pred <- predict(gamSpline_city, Data_test_city)

# make obs and pred dataset
Data_train_city <- data.table(Data_train_city)
Data_test_city <- data.table(Data_test_city)

HogeData <- rbind(HogeData, Data_train_city[, list(TrainTest, ID, Date, AMPM, SeverityHigherMid, Pred), ])
HogeData <- rbind(HogeData, Data_test_city[, list(TrainTest, ID, Date, AMPM, SeverityHigherMid, Pred), ])

}

HogeResults
HogeData[, Pred := ifelse(Pred >= 10000, 10000, Pred), ]
HogeData %>% fwrite("Out_obs_pred_cityspeficit_model.csv")

toc()

```

# info
```{r}
sessionInfo()

```