#' Extract Head-Change Values and Cell Locations from the .lst file
#'
#' This function extracts the Head-Change value and the locations of the cells exhibiting the
#' maximum head-change value from the .lst file.
#'
#' @param LISTFL This is the full name (including filepath) of the .lst file.
#' @export

read_nwt_lst <- function(LISTFL){
    linin <- readr::read_lines(LISTFL) %>% .[-grep("#", .)]
    HDCHNG_LOC_STRT <- grep("Residual-Control", linin)
    HDCHNG_LOC_END <- dplyr::lead(HDCHNG_LOC_STRT) - 2

    if(any(grepl("NWT REQUIRED", linin))){
        HDCHNG_LOC_END[length(HDCHNG_LOC_END)] <- grep("NWT REQUIRED", linin) - 3
    }else{
        HDCHNG_LOC_STRT <- HDCHNG_LOC_STRT[1:(length(HDCHNG_LOC_STRT) - 1)]
        HDCHNG_LOC_END  <- HDCHNG_LOC_END[1:length(HDCHNG_LOC_STRT)]
        }

    HDCHNG_LOCS <- purrr::map2(HDCHNG_LOC_STRT + 1, HDCHNG_LOC_END, ~seq(.x, .y)) %>% unlist()
    COL_NAMES <- linin[HDCHNG_LOCS[1] - 1] %>%
                    stringr::str_trim() %>%
                    strsplit("\\s+") %>%
                    unlist()

    COL_NAMES[COL_NAMES == "Column"][1] <- "COL"
    COL_NAMES[COL_NAMES == "Row"][1]    <- "ROW"
    COL_NAMES[COL_NAMES == "Layer"][1]  <- "LAY"
    COL_NAMES[COL_NAMES == "Column"]    <- "MAX_FLUX_COL"
    COL_NAMES[COL_NAMES == "Row"]       <- "MAX_FLUX_ROW"
    COL_NAMES[COL_NAMES == "Layer"]     <- "MAX_FLUX_LAY"
    COL_NAMES[COL_NAMES == "Outer-Iter."]     <- "ITER"
    COL_NAMES[COL_NAMES == "Inner-Iter."]     <- "INNER_ITER"
    COL_NAMES[COL_NAMES == "Max.-Head-Change"]     <- "HDCHNG"
    COL_NAMES[COL_NAMES == "Max.-Flux-Residual"]     <- "FLXCHNG"

    HDCHNG <- linin[HDCHNG_LOCS] %>%
                    stringr::str_trim() %>%
                    stringr::str_split_fixed("\\s+", n = Inf) %>%
                    tibble::as_tibble()
    colnames(HDCHNG) <- COL_NAMES

    out <- HDCHNG %>% dplyr::mutate(`Residual-Control` = as.integer(`Residual-Control`),
                                    ITER = as.integer(ITER),
                                    INNER_ITER = as.integer(INNER_ITER),
                                    COL = as.integer(COL),
                                    ROW = as.integer(ROW),
                                    LAY = as.integer(LAY),
                                    MAX_FLUX_COL = as.integer(MAX_FLUX_COL),
                                    MAX_FLUX_ROW = as.integer(MAX_FLUX_ROW),
                                    MAX_FLUX_LAY = as.integer(MAX_FLUX_LAY),
                                    HDCHNG = as.numeric(HDCHNG),
                                    FLXCHNG = as.numeric(FLXCHNG),
                                    `L2-New` = as.numeric(`L2-New`),
                                    `L2-Old` = as.numeric(`L2-Old`),
                                    `Solver-Max-Delh` = as.numeric(`Solver-Max-Delh`))
    return(out)
}


#' Plot effective sample size (Neff)
#'
#' Effective sample size is a measure of how precisely age composition is measured. Plots made by fleet.
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @param is.catch.flag true means only catch plotted, false also plots discards (defaults to TRUE)
#' @export

PlotFleetNeff <- function(asap,fleet.names,save.plots,od,plotf,liz.palette,is.catch.flag=TRUE){
  par(mfrow=c(1,1) )

  years <- seq(asap$parms$styr, asap$parms$endyr)
  Neff.init <- asap$fleet.catch.Neff.init
  Neff.est <- asap$fleet.catch.Neff.est
  my.title <- "Catch Neff Fleet "
  my.save <- "Catch.Neff.F"
  if (!is.catch.flag){
    Neff.init <- asap$fleet.discard.Neff.init
    Neff.est <- asap$fleet.discard.Neff.est
    my.title <- "Discard Neff Fleet "
    my.save <- "Discard.Neff.F"
  }
  for (i in 1:asap$parms$nfleets) {
    if (sum(Neff.init[i,]) > 0){
      plot(years,Neff.init[i,], type='p', col=liz.palette[i], pch=1, xlab="Year", ylab="Effective Sample Size",
           ylim=c(0, 1.1*max(Neff.init[i,],Neff.est[i,])) )
      lines(years, Neff.est[i,], col=liz.palette[i], lwd=2)
      title (paste0(my.title, i, " (", fleet.names[i], ")") )
      if (save.plots) savePlot(paste0(od, my.save, i, ".", plotf), type=plotf)
    }
  } #end loop nfleets
  return()
}


REBOL [
	Title:   "Regression tests script for Red/System Compiler"
	Author:  "Boleslav Březovský"
	File: 	%regression-test-rsc.r
	Rights:  "Copyright (C) 2016 Boleslav Březovský. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/origin/BSD-3-License.txt"
]

;cd %../
;--separate-log-file

~~~start-file~~~ "Red/System Compiler Regression tests"

; help functions for crash and compiler-problem detection
true?: func [value] [not not value]
crashed?: does [true? find qt/output "*** Runtime Error"]
compiled?: does [true? not find qt/comp-output "Error"]
script-error?: does [true? find qt/output "Script Error"]
compiler-error?: does [true? find qt/comp-output "*** Compiler Internal Error"]
compilation-error?: does [true? find qt/comp-output "*** Compilation Error"]
loading-error: func [value] [found? find qt/comp-output join "*** Loading Error: " value]
compilation-error: func [value] [found? find qt/comp-output join "*** Compilation Error: " value]
syntax-error: func [value] [found? find qt/comp-output join "*** Syntax Error: " value]
-test-: :--test--
--test--: func [value] [probe value -test- value]

===start-group=== "Red/System regressions #1 - #1000"

	--test-- "#28"
		--compile-this {
Red/System []
i: 1 * 0
}
		--assert compiled?

	--test-- "#32"
		--compile-this {
Red/System []

f: func [
	result: [integer!]
] []
}
		--assert not compiled?

	--test-- "#55"
		--compile-this {
Red/System []
i: 0
i: "A"
}
		--assert not compiled?

	--test-- "#59"
		--compile-this {
Red/System []
exit
}
		--assert not compiled?
		--compile-this {
Red/System []
return
}
		--assert not compiled?

	--test-- "#76"
		--compile-and-run-this {
Red/System []
a: "0"
a/1: a/1 + (2 * 2)
print a
}
		--assert equal? "4" qt/output

	--test-- "#88"
		--compile-this {
Red/System []
s: declare struct! []
}
		--assert not compiled?

	--test-- "#89"
		--compile-this {
Red/System []
OemToChar: 123
}
		--assert compiled?

	--test-- "#136"
		--compile-and-run-this {
Red/System []
a: declare struct! [x [byte!] y [logic!]]
prin-int size? a
}
		--assert equal? "8" qt/output

	--test-- "#138"
		--compile-this {
Red/System []
(1 + 2) and 3
}
		--assert compiled?

	--test-- "#139"
		--compile-this {
Red/System []
assert all [1 = 2]
}
		--assert compiled?

	--test-- "#146"
		--compile-and-run-this {
Red/System []
s: declare struct! [
	a [byte!]
	b [byte!]
	c [byte!]
	d [byte!]
]
s/a: as-byte 1
s/b: as-byte 1
s/c: as-byte 0
s/d: as-byte 0
print as-integer s/a
}
		--assert equal? "1" qt/output

	--test-- "#148"
		--compile-this {
Red/System []
i: declare pointer! [integer!]
b: declare pointer! [byte!]
i: (as pointer! [integer!] b) + 1 + 1
}
		--assert compiled?

	--test-- "#149"
		--compile-and-run-this {
Red/System []
a: declare struct! [value [integer!]]
a/value: 0
p: as pointer! [byte!] a
p/1: as-byte 1
p/2: as-byte 2
print a/value
}
		--assert equal? "513" qt/output

	--test-- "#150"
		--compile-and-run-this {
Red/System []
s!: alias struct! [
	a	[byte!]
	b	[byte!]
	c	[byte!]
	d	[byte!]
]
t: declare s!
t/a: as-byte 1
t/b: as-byte 1
t/c: as-byte 0
t/d: as-byte 0
h: as-integer t/a
print h
}
		--assert equal? "1" qt/output

	--test-- "#151"
		--compile-and-run-this {
Red/System []
a: declare struct! [value [integer!]]
a/value: 0
p: as pointer! [byte!] a
print as-integer p
print newline
print as-integer p +
    1 +
    (1 * 3)
}
		--assert not equal? #"3" last qt/output

	--test-- "#158"
		--compile-and-run-this {
Red/System []
a: as-byte 10h
b: as-byte 80h
print as-integer a
}
		--assert equal? "16" qt/output

	--test-- "#159"
		--compile-and-run-this {
Red/System []
a: as-byte 10h
b: as-byte 80h
c: as-integer a
print c
}
		--assert equal? "16" qt/output

	--test-- "#160"
		--compile-and-run-this {
Red/System []
#define as-binary [as pointer! [byte!]]
a: as-byte 1
b: as-byte 2
print [as-binary (as-integer a) * 2 " "]
print [as-binary (as-integer a) << 2]
}
		--assert equal? "00000002 00000004" qt/output

	--test-- "#161"
		--compile-and-run-this {
Red/System []
a: as-byte 1
b: as-byte 2
print as byte-ptr! (as-integer b) << 16 or as-integer a
}
		--assert equal? "00020001" qt/output

	--test-- "#162"
		--compile-and-run-this {
Red/System []
s: declare struct! [
	a	[byte!]
	b	[byte!]
]
s/a: as-byte 0
s/b: as-byte 1
print as-logic s/a
}
		--assert equal? "false" qt/output

	--test-- "#164"
		--compile-and-run-this {
Red/System []
s: declare struct! [
	a	[byte!]
	b	[byte!]
]
s/a: as-byte 0
s/b: as-byte 1
print either as-logic s/a ["bogus"] [""]
}
		--assert empty? qt/output

	--test-- "#169"
		--compile-this {
Red/System []
s!: alias struct! [x [integer!]]

x: function [
	return: [s!]
][
	either true [
		as s! 0
	][
		null
	]
]
}
		--assert compiled?

	--test-- "#171"
		--compile-and-run-this {
Red/System []
x: as struct! [x [integer!]] 0
if as-logic x [
	print "not null"
]
y: as pointer! [byte!] 0
if as-logic y [
	print "not null"
]
}
		--assert empty? qt/output

	--test-- "#173"
		--compile-and-run-this {
Red/System []
x: as struct! [x [integer!]] 1
if as-logic x [
	print "not null "
]
y: as pointer! [byte!] 1
if as-logic y [
	print "not null"
]
}
		--assert equal? "not null not null" qt/output

	--test-- "#175"
		--compile-and-run-this {
Red/System []
s!: alias struct! [x [integer!]]
p: declare s!
unless as-logic p [
	print "true = as-logic not non-null"
]
}
		--assert empty? qt/output

	--test-- "#198"
		--compile-and-run-this {
Red/System []
print ["started"]

f: func [
	i               [integer!]
	s               [c-string!]
	return:         [integer!]
	/local
	divisor         [integer!]
] [
	divisor: 0

	switch i [
		0 [
			return 0
		]
		-2147483648 [
			return 0
		]
		default [
			until [
				divisor = 0
			]
		]
	]
	0
]
s: " "
f 1 s
print [s]
print ["finished"]
}
		--assert compiled?
		--assert equal? "started finished" qt/output

	--test-- "#205"
		--compile-and-run-this {
Red/System []
f1: function [
    return: [float!]
][
    1.0
]
f2: function [
    return: [float!]
][
    2.0
]

print [
    1.0 / 2.0 " "
    f1 / f2
]
}
		--assert equal? "0.5 0.5" qt/output

	--test-- "#207"
		--compile-this {
Red/System []
#define x 0
comment [
	#define x 0
]
}
		--assert compiled?

	--test-- "#208"
		--compile-and-run-this {
Red/System []
test: function [
	a	[float!]
	b	[float!]
][
	print-wide [a b " "]
	print-wide [as-float32 a as-float32 b]
]
print-wide [as-float32 0.0 as-float32 1.0 " "]
test 0.0 1.0
}
		--assert equal? "0.0 1.0  0.0 1.0  0.0 1.0" qt/output

	--test-- "#209"
		--compile-and-run-this {
Red/System []
print [as-float32 0.0  lf]
}
		--assert not crashed?

	--test-- "#210"
		--compile-and-run-this {
Red/System []
print [as-float32 0.0  lf]
print-wide [as-float32 0.0  as-float32 1.0  lf]

test: function [
	a	[float!]
	b	[float!]
][
	print-wide [a b lf]
	print-wide [as-float32 a  as-float32 b  lf]
]
print-wide [as-float32 0.0  as-float32 1.0  lf]
test 0.0 1.0
}
		--assert not crashed?

	--test-- "#216"
		--compile-and-run-this {
Red/System []
i: 2.0
print i / (i - 1.0)
}
		--assert equal? "2.0" qt/output

	--test-- "#217"
		--compile-and-run-this {
Red/System []
i: 1
f: 0.0
arr: as pointer! [float!] allocate 10 * size? float!

while [i <= 10] [
	arr/i: f
	f: f + 0.1
	i: i + 1
]
}
		--assert not crashed?

	--test-- "#220"
		--compile-and-run-this {
Red/System []
i: 1
f: 0.0
arr: as pointer! [float!] allocate 10 * size? float!

while [i <= 10] [
	arr/i: f
	f: f + 0.1
	print [i ":" as-float32 arr/i lf]
	i: i + 1
]
}
		--assert not crashed?

	--test-- "#221"
		--compile-and-run-this {
Red/System []
x: -1.0
y: either x < 0.0 [0.0 - x][x]
print [y lf]
}
		--assert not crashed?
		--compile-and-run-this {
Red/System []
fabs: func [x [float!] return: [float!] ][
	either x < 0.0 [0.0 - x][x]
]
print [fabs -3.14 lf]
}
		--assert not crashed?

	--test-- "#222"
		--compile-and-run-this {
Red/System []
s: declare struct! [value [float!]]
s/value: 1.0
a: as pointer! [float!] allocate 100 * size? float!
a/1: s/value
a/1: s/value
1 + 1
}
		--assert not crashed?
		--compile-and-run-this {
Red/System []
s: declare struct! [value [float!]]
s/value: 1.0
a: as pointer! [float!] allocate 100 * size? float!
a/1: s/value
a/1: s/value
if true [a/1: s/value]
}
		--assert not crashed?

	--test-- "#223"
		--compile-and-run-this {
Red/System []
i: 1
while [i <= 10][
	0.0
	i: i + 1
]
}
		--assert not crashed?
		--compile-and-run-this {
Red/System []
a: as pointer! [float!] allocate 10 * size? float!
i: 1
f: 1.0
while [i <= 7][
	f: f * 0.8
	print [f lf]
	a/i: f
	i: i + 1
]
}
		--assert not crashed?
		--compile-and-run-this {
Red/System []
a: as pointer! [float!] allocate 10 * size? float!
i: 1
f: 1.0
while [i <= 10][
	f: f * 0.8
	print [f lf]
	a/i: f
	i: i + 1
]
}
		--assert not crashed?

	--test-- "#224"
		--compile-this {
Red/System []
n: 1
n: not n
}
		--assert compiled?

	--test-- "#225"
		--compile-and-run-this {
Red/System []
i: 1.0
f: 1.0
data: declare pointer! [float!]
data: :f
while [i < 10.0][
	data/value: i
	i
	i: i + 1.0
]
}
		--assert not crashed?

	--test-- "#226"
		--compile-and-run-this {
Red/System []
number: 10
array: declare pointer! [byte!]
array: as byte-ptr! :number
value: as integer! array/value
print [10 * as integer! array/value lf]
}
		--assert not crashed?

	--test-- "#227"
		--compile-and-run-this {
Red/System []
t: 2.2
s: declare struct! [v [float!]]
s/v: 2.0
print [t - s/v]
}
		--assert equal? "0.2" copy/part qt/output 3 ; prevent rounding errors

	--test-- "#229"
		--compile-this {
Red/System []
not as byte! 0
}
		--assert compiled?

	--test-- "#231"
		--compile-this {
Red/System []
f: func [
	[typed]
	count	[integer!]
	list	[typed-value!]
][
	pi: declare pointer! [integer!]
	pi: as pointer! [integer!] list/value
]

f [:i]
}
		--assert not compiler-error?

	--test-- "#233"
		--compile-this {
Red/System []
#enum type! [
	x
]

f: function [
	a [type!]
][
]

g: function [
	a [type!]
][
	f a
]
}
		--assert compiled?

	--test-- "#235"
		--compile-this {
Red/System []
a!: alias struct! [a [byte!]]
system/alias/a!
}
		--assert compiled?

	--test-- "#238"
		--compile-this {
Red/System []

c: context [
	s!: alias struct! [dummy [integer!]]
]

with c [
	f: function [
		p [s!]
	][
	]
]
}
		--assert compiled?

	--test-- "#241"
		--compile-this {
Red/System []
c: context [
    #enum e! [i]
]

with c [
	f: function [
		return: [e!]
	][
		i
	]
]
}
		--assert compiled?

	--test-- "#243"
		--compile-this {
Red/System []
c: context [
	#enum e! [x]
]

with c [
	f: function [
		p [float!]
	][
	]

	x: 0.0
	f x
]
}
		--assert compilation-error?

	--test-- "#244"
		--compile-this {
Red/System []
a: "REBOL []"
b: {REBOL []}
c: {
	REBOL
}
d: {
	REBOL []
}
}
		--assert compiled?

	--test-- "#245"
		--compile-this {
Red/System []
a: declare struct! [
	b [integer!]
	b [byte!]
]

a/b: 123
print a/b
}
		--assert compilation-error?

	--test-- "#253"
		--compile-this {
Red/System []
context []
}
		--assert true? find qt/comp-output "*** Compilation Error: context's name setting is missing"

	--test-- "#254"
		--compile-this {
Red/System []
c: context [
	#enum e! [
		x
	]

	f: function [
		a [e!]
	][
	]
]
}
		--assert compiled?

	--test-- "#257"
		--compile-this {
Red/System []
s!: alias struct! [a [integer!]]
c: context [
	a: declare s!
]
}
		--assert compiled?

	--test-- "#261"
		--compile-this {
Red/System []
prin "123"
}
		--assert compiled?

	--test-- "#263"
		--compile-this {
Red/System []
p1: as byte-ptr! "test"
a: (as-integer p1/value) << 8
print a
}
		--assert compiled?

	--test-- "#272"
		--compile-and-run-this {
Red/System []
foo: func [return: [logic!]][
	either true [
		1 = 3
	][
		false
	]
]
print foo
}
		--assert equal? "false" qt/output

;;-- removed due to // and % operators made obsolete
; 	--test-- "#273"
; 		--compile-this {
; Red/System []
; 4.0 // 2.0
; }
; 		--assert compiled?

;;-- removed due to // and % operators made obsolete
; 	--test-- "#275"
; 		--compile-and-run-this {
; Red/System []
; a: 600851475143.0 ;prime number
; i: 2.0
; while [i * i <= a] [
; 	if a // i = 0.0 [
; 		a: a / i
; 	]
; 	i: i + 1.0
; ]
; print a
; }
; 		--assert not crashed?

	--test-- "#281"
		--compile-this {
Red/System []
if false [c: context [d: 1]]
}
		--assert found? find
			qt/comp-output
			"*** Compilation Error: context has to be declared at root level"

	--test-- "#282"
		--compile-this {
Red/System []
c: "HELLO"
c: context [b: 2]
b: 1
print c/b
}
		--assert found? find
			qt/comp-output
			"*** Compilation Error: context name is already taken"

	--test-- "#284"
		--compile-this {
Red/System []
c: context [
	f: func [[infix] a [integer!] b[integer!] return: [integer!]][a + b]
]
print 1 c/f 2
}
		--assert found? find
			qt/comp-output
			"*** Compilation Error: infix functions cannot be called using a path"

	--test-- "#285"
		--compile-this {
Red/System []
c: context [
	f: func [[infix] a [integer!] b [integer!] return: [integer!]][a + b]
	print 1 f 2
]
}
		--assert compiled?

	--test-- "#288"
		--compile-this {
Red/System []
#define a(b not) [b + not] print a(1 2)
}
		--assert loading-error "keywords cannot be used as macro parameters"
		--compile-this {
Red/System []
#define a(b 5) [b + 5] print a(1 2)
}
		--assert loading-error "only words can be used as macro parameters"
		--compile-this {
Red/System []
#define a(b "c") [b + "c"] print a(1 2)
}
		--assert loading-error "only words can be used as macro parameters"

	--test-- "#289"
		--compile-this {
Red/System []
print 1 + "c"
		}
		--assert compilation-error "a literal string cannot be used with a math operator"

	--test-- "#290"
		--compile-this {
Red/System []
#enum color! [a b c]
print #"^^(0A)"
}
		--assert compiled?

	--test-- "#291"
		--compile-this {
Red/System []
f: func[a [integer!]][a: context [b: 1]]
}
		--assert compilation-error "context name is already taken"

	--test-- "#293"
		--compile-this {
Red/System []
c: context [
	#enum e! [x]
	f: function [
		a		[e!]
		return: [logic!]
	][
		zero? a
	]
]
}
		--assert compiled?

	--test-- "#298"
		--compile-this {
Red/System []
#enum color! [a b c] print size? color!
}
		--assert compiled?

	--test-- "#300"
		--compile-this {
Red/System []
v: declare pointer![float64!] d: 1.0 v: :d
}
		--assert compiled?

	--test-- "#317"
		--compile-and-run-this {
Red/System []
a: as-byte 1
b: as-byte 2
c: as-byte 3
d: as-byte 4
a: as-byte 0
print-wide [as-integer a as-integer b as-integer c as-integer d]
}
		--assert equal? "0 2 3 4" qt/output

	--test-- "#334"
		--compile-this {
Red/System []

#define def (a) [
	v: a
]
b: true
def ((not b))
}
		--assert compiled?

	--test-- "#338"
		--compile-this {
Red/System []
a: as pointer! [integer!] allocate 10 * size? integer!
c: context [
	i: 1
	a/i: i
]
}
		--assert compiled?

	--test-- "#344"
		--compile-and-run-this {
Red/System []
b: as-byte 0
print as-integer not as-logic b
b: as-byte 1
print as-integer not as-logic b
b: as-byte 2
print as-integer not as-logic b
}
		--assert equal? "100" qt/output

	--test-- "#346"
		--compile-this {
Red/System []
#import [LIBC-file cdecl [
    to-float: "atof" ["Parse string to floating point."
        string      [c-string!]
        return:     [float!]
    ]
]]
print (to-float "1")
}
		--assert compiled?

	--test-- "#348"
		--compile-this {
Red/System []
c1: context [
	c2: context [
		x: 0
	]
	with c2 [
		x: 1
	]
]
}
		--assert compiled?

	--test-- "#379"
		--compile-this {
Red/System []
c: context [
	#import [LIBC-file cdecl [
		print-error: "perror" [  ; Print error to stderr.
			string	[c-string!]
		]
	]]
]
c/print-error "."
with c [
    print-error "!"
]
}
		--assert compiled?

	--test-- "#393"
		--compile-this {
Red/System []

d: does [
]
x: either yes [:d] [:d]
print-line :x
}
		--assert compiled?

	--test-- "#417"
		--compile-this {
Red/System []
{
	REBOL []
}
}
		--assert compiled?

	--test-- "#419"
		--compile-and-run-this {
Red/System []

str: "123"
p: as byte-ptr! str
print-line as-integer p/1
either (as integer! str) = (as integer! p) [print ["ok" lf]] [print ["ko" lf]]

s: as struct! [a [integer!]] str
print-line s/a
either (as integer! str) = (as integer! s) [print ["ok" lf]] [print ["ko" lf]]
}
		--assert not found? find qt/output "ko"

;	--test-- "#473"
;		TODO: causes compiler problems, see #2240

	--test-- "#474"
		--compile-this {
Red/System []
c: context [
	s!: alias struct! [
		f [function! []]
	]

	r: declare struct! [s [s!]]
]
with c [
    r/s/f
]
}
		--assert compiled?

	--test-- "#475"
		--compile-this {
Red/System []
s: declare struct! [
	f [
		function! [
			""
	    	i       [integer!]
	    	return: [integer!]
		]
	]
]
print [s/f]
}
		--assert compilation-error "s/f is missing an argument"

	--test-- "#481"
		--compile-this {
Red/System []
c1: context [
	x: 1
	f: does []
]
with c1 [
	c2: context [
		x: 2
		f: does []
	]
]
with c2 [
	c2/f
	print-line c2/x
	print-line x
	f
]
}
		--assert compiled?

	--test-- "#483"
		--compile-this {
Red/System []
#define LTM-MP-zero-set(digit size) [
	LTM-MP-digit-counter: size
	until [
		digit/value: null-byte
		digit: digit + 1
		LTM-MP-digit-counter: LTM-MP-digit-counter - 1
		LTM-MP-digit-counter = 0
	]
]
LTM-mp-int!: alias struct! [
	used		[integer!]
	alloc		[integer!]
	sign		[integer!]
	mp-digit	[byte-ptr!]
]
mp-int: declare LTM-mp-int!
mp-int/used: 0
mp-int/alloc: 32
mp-int/sign: 0
mp-int/mp-digit: allocate 32
LTM-MP-zero-set(mp-int/mp-digit 32)
}
		--assert compiled?

	--test-- "#526"
		--compile-and-run-this {
Red/System []
print-wide [
	"A" newline
	"B"
]
}
		--assert equal? "A ^/B" qt/output

	--test-- "#528"
		--compile-and-run-this {
Red/System []
s: system/args-list + either yes [0] [1]
print-wide [system/args-list s]
}
		--assert equal?
			copy/part qt/output 8
			copy/part tail qt/output -8

	--test-- "#533"
		--compile-this {
Red/System []
f: function [
	/local x
][
	print :x
]
}
		--assert compilation-error "local variable x used before being initialized"

	--test-- "#535"
		--compile-this {
Red/System []
c: context [
	x: 0
	print :x
]
}
		--assert compiled?

	--test-- "#552"
		--compile-and-run-this {
Red/System []
pos: as byte-ptr! "test"
cp: 0
print pos/value
pos/value: pos/value + as-byte 1 << (cp and 7)
print pos/value
}
		--assert equal? "tu" qt/output

	--test-- "#554"
		--compile-and-run-this {
Red/System []
a: yes
b: yes
probe a xor b
}
		--assert not crashed?

	--test-- "#555"
		--compile-and-run-this {
Red/System []
true and true
}
		--assert not crashed?

	--test-- "#751"
		; FIXME: regressed, see the issue
; 		--compile-this {
; Red/System []
; foo: 458724589764398757698437598437598347
; print [foo lf]
; }
; 		--assert syntax-error "Invalid integer! value"

	--test-- "#810"
		; FIXME: not fixed, see the issue
; 		--compile-and-run-this {
; Red/System []
; res: case [
; 	true [1 = 0]
; ]
; print res
; }
; 		--assert equal? "false" qt/output

	--test-- "#858"
		--compile-and-run-this {
Red/System []
k: as pointer! [integer!] 1
print ["k: " as integer! k " "]
i: 1
m: as pointer! [integer!] i
print ["m: " as integer! m " "]
k: as pointer! [integer!] 10
print ["k: " as integer! k " "]
k: as pointer! [integer!] -10
print ["k: " as integer! k " "]
k: as pointer! [integer!] 0
print ["k: " as integer! k]
}
		--assert equal? "k: 1 m: 1 k: 10 k: -10 k: 0" qt/output

	--test-- "#861"
		--compile-and-run-this {
Red/System []
int64!: alias struct! [int1 [integer!] int2 [integer!]]
print-float-hex: func [
	number  [float!]
	tmp     [integer!]
	/local
		f   [int64!]
][
	f: as int64! :number
	print [as byte-ptr! f/int2 as byte-ptr! f/int1]
]
foo-test: func [
	/local
		f   [float!]
		p   [pointer! [float!]]
		a   [int64!]
		tmp [integer!]
][
	f: 0.0
	a: as int64! :f
	p: as pointer! [float!] a
	tmp: 20
	print [as byte-ptr! a/int2 as byte-ptr! a/int1]
	print-float-hex p/value tmp
	print [as byte-ptr! a/int2 as byte-ptr! a/int1]
]
foo-test
}
		--assert 1 = length? unique qt/output

	--test-- "#880"
		--compile-and-run-this {
Red/System []
print switch 1 [
	0 ["a"]
	1 ["b"]
	2 ["c"]
	3 ["d"]
]
}
		--assert not crashed?

	--test-- "#884"
		--compile-this {
red/system []
print "1"
}
		--assert not compiled?

		--compile-this {
Red/system []
print "1"
}
		--assert not compiled?

===end-group===

===start-group=== "Red/System regressions #1001+"

	--test-- "#1322"
		--compile-and-run-this {
Red/System []
bad: context [
	pen: 123
	system-func: func [pen [int-ptr!]][
		pen/value: 33
	]
	change-pen: func [
		/local
			pen [integer!]
	][
		pen: 0
		system-func :pen
	]
	print pen
	change-pen
	print pen
]
}
		--assert equal? "123123" qt/output

	--test-- "#1324"
		--compile-this {
Red/System []
#import [
	LIBC-file cdecl [
		lol: "funny" [
			return [whoops!]
		]
	]
]
}
		--assert compilation-error "Cannot use `return` as argument name"

; 	TODO: how to check for infinite loop?
	--test-- "#1397"
		--compile-and-run-this {
Red/System []
loop 0 [print 123]
}
	;-- no assertion here, if it didn't hang, it's good

	--test-- "#1545"
		--compile-and-run-this {
Red/System []
print [1 lf]
}
		--assert not crashed?

	--test-- "#1710"
		--compile-this {
Red/System []
bad-error-msg: func [/local a [logic!]][
	if a: true [0]
]
bad-error-msg
}
		--assert compilation-error "assignment not supported in conditional expression"

	--test-- "#2019"
		--compile-and-run-this {
Red/System []
s: declare struct! [time [float!]]
s/time: 3E9
print s/time / 1E6
}
		--assert equal? "3000.0" qt/output

	--test-- "#2135"
		--compile-and-run-this {
Red/System []
probe 1.836E13
}
		--assert not found? find qt/output "13.0"

	--test-- "#3662"
		--compile-this {Red/System [] 1h}				;@@ allow it?
		--assert loading-error "invalid hex literal"

		--compile-this {Red/System [] 100000000h}
		--assert loading-error "invalid hex literal"

		--compile-and-run-this {
			Red/System []
			probe 10h
			probe 100h
			probe 1000h
			probe 10000h
			probe 100000h
			probe 1000000h
			probe 10000000h
		}
		--assert equal?
			load qt/output
			[16 256 4096 65536 1048576 16777216 268435456]

	--test-- "#2671"
		--compile-and-run-this {
Red/System []

string: "^^(0)^^(1)^^(2)^^(3)^^(4)^^(5)^^(6)^^(7)^^(8)^^(9)^^(A)^^(B)^^(C)^^(D)^^(E)^^(F)"
binary: #{000102030405060708090A0B0C0D0E0F}
array:  [
	#"^^(0)" #"^^(1)" #"^^(2)" #"^^(3)"
	#"^^(4)" #"^^(5)" #"^^(6)" #"^^(7)"
	#"^^(8)" #"^^(9)" #"^^(A)" #"^^(B)"
	#"^^(C)" #"^^(D)" #"^^(E)" #"^^(F)"
]

this: compare-memory
	as byte-ptr! string
	binary
	length? string

that: compare-memory
	array
	binary
	length? string

probe [this that]
}

		--assert 0 = load qt/output

		--compile-this {Red/System [] #"^^(0000001)"}
		--assert syntax-error "Invalid char! value"

		--compile-this {Red/System [] "^^(0000001)"}
		--assert syntax-error "Invalid string! value"

		--compile-this {Red/System [] #"^^(skibadee-skibadanger)"}
		--assert syntax-error "Invalid char! value"

		--compile-this {Red/System [] "^^(skibadee-skibadanger)"}
		--assert syntax-error "Invalid string! value"

===end-group===

~~~end-file~~~


setwd("~/scratch")
library(dplyr)

df_raw <- read_csv("2017_BRFSS_HTN_OBESITY_DIABETES.csv")

df_raw %>% names()

df_selected <- df_raw %>% select(Year,Locationabbr,Locationdesc,Class,Topic,Question,Response,Break_Out_Category,Break_Out, Sample_Size,Data_value,Data_value_unit,Confidence_limit_Low,Confidence_limit_High)

# Diabetes
df_diabetes <- df_selected %>% filter(Topic == "Diabetes")
df_diabetes_final <- df_diabetes %>%
  filter(Response == "Yes") %>%
  arrange(Locationabbr,Class,Topic,Break_Out,Break_Out_Category)

write.csv(df_diabetes_final,"comorbidities_diabetes_BRFSS_2017.csv",row.names = FALSE)

# Obesity
df_obesity <- df_selected %>% filter(Class == "Overweight and Obesity (BMI)")
df_obesity_final <- df_obesity %>%
  filter(Response == "Obese (bmi 30.0 - 99.8)") %>%
  arrange(Locationabbr,Class,Topic,Break_Out,Break_Out_Category)

write.csv(df_obesity_final,"comorbidities_obesity_BRFSS_2017.csv",row.names = FALSE)

# Hypertension
df_HTN <- df_selected %>%
  filter(Topic =="High Blood Pressure")

df_HTN_final <- df_HTN %>%
  filter(Topic =="High Blood Pressure") %>%
  arrange(Locationabbr,Class,Topic,Break_Out,Break_Out_Category)

write.csv(df_HTN_final,"comorbidities_hypertension_BRFSS_2017.csv",row.names = FALSE)

# scratch below
# # Diabetes
# df_diabetes <- df_selected %>% filter(Topic == "Diabetes")
# df_diabetes_final <- df_diabetes %>%
#   filter(Response == c("Yes", "No", "No, pre-diabetes or borderline diabetes")) %>%
#   mutate(Response = replace(Response, Response == "No, pre-diabetes or borderline diabetes", "No")) %>%
#   arrange(Locationabbr,Class,Topic,Break_Out,Break_Out_Category)


context("Bind")

test_that("Number of rows grow with rbind", {

  lay1 <- gtable_add_rows(gtable(), cm)
  lay2 <- gtable_add_rows(gtable(), rep(cm, 2))

  expect_that(nrow(rbind(lay1, lay2)), equals(3))
  expect_that(nrow(rbind(lay2, lay1)), equals(3))
})

test_that("Number of cols grow with cbind", {

  lay1 <- gtable_add_cols(gtable(), cm)
  lay2 <- gtable_add_cols(gtable(), rep(cm, 2))

  expect_that(ncol(cbind(lay1, lay2)), equals(3))
  expect_that(ncol(cbind(lay2, lay1)), equals(3))
})

test_that("Heights and widths vary with size parameter", {
  col1 <- gtable_col("col1", list(grob1), cm, cm)
  col2 <- gtable_col("col1", list(grob1), cm2, cm2)

  expect_equal(cbind(col1, col2, size = "first")$heights, cm)
  expect_equal(cbind(col1, col2, size = "last")$heights, cm2)
  expect_equal(cbind(col1, col2, size = "min")$heights, cm)
  expect_equal(cbind(col1, col2, size = "max")$heights, cm2)

  expect_equal(rbind(col1, col2, size = "first")$widths, cm)
  expect_equal(rbind(col1, col2, size = "last")$widths, cm2)
  expect_equal(rbind(col1, col2, size = "min")$widths, cm)
  expect_equal(rbind(col1, col2, size = "max")$widths, cm2)
})


#: bring in those significant variables

result_isna_association_pvalue <- foreach( vn = ses_variable_names, .combine = c) %do% {

  temp_value <- joined_dt[[vn]]

  temp_value_binary <- ifelse(is.na(temp_value), yes = 0, no = 1)

  message(mean(temp_value_binary))

  if (n_distinct(temp_value_binary) == 2) {

    set(joined_dt, i = NULL, j = sprintf("%s_isNA_factor", vn), value = temp_value_binary %>% as.factor)

  }

  message(vn, "finished!")

  return (NULL)

}


library(devtools)
library(parallel)
devtools::load_all()
RNGkind("L'Ecuyer-CMRG")
data(grid)

seed <- 999983
s_k <- 1000
s_n <- 100
s_m <- 4

direct_trig_1004 <- mclapply(r_grid_trig[-1], r_loop <- function(s_r) {
    sim_direct(seed, s_k, s_n, s_m, dev = "trigonometric", r = s_r)
}, mc.cores = 2)

save(direct_trig_1004, file = "direct_trig_1004.RData")


\name{BvCat.predict}
\alias{BvCat.predict}
\title{Function to perform prediction based on fitted penalized bivariate multinomial logistic regression model.}
\usage{
  BvCat.predict(Xtest, fit, lambda = NULL, gamma = NULL, type="class")
}
\arguments{
\item{Xtest}{An \eqn{n_{\rm test} \times p} matrix of predictors at which to make new predictions. Should be on the same scale as \code{X} input into \code{BvCat.cv}.}
\item{fit}{An fitted model object of type \code{BvCat} obtained from the \code{BvCat.cv} function. }
\item{lambda}{Value of tuning parameter \eqn{\lambda} at which to extract coefficients. If \code{NULL}, will use values which minimized joint misclassificaiton error (assuming \code{nfolds} \eqn{ > 2}). If not \code{NULL}, must be a value from \code{fit$lambda.vec}.}
\item{gamma}{Value of tuning parameter \eqn{\gamma} at which to extract coefficients. If \code{NULL}, will use values which minimized joint misclassificaiton error (assuming \code{nfolds} \eqn{ > 2}). If not \code{NULL}, must be a value from \code{fit$gamma.vec}.}
\item{type}{In what form should the prediction be returned? options are "\code{class}" or "\code{probabilities}". If "\code{class}", will return as \eqn{n_{\rm test} \times 2} matrix with predicted category for the first and second response in each column. If "\code{probabilities}", will return a \eqn{n_{\rm test} \times J \times K} array of probabilities. }
}

\value{
   \item{preds}{The prediction object as determined by argument \code{type}}.
}

\examples{
# ----------------------------------------
# Example for BvCategorical
# ----------------------------------------
set.seed(1)
p <- 50
n <- 300
J <- 3
K <- 2
Results <- NULL
SigmaX <- matrix(0, nrow=p, ncol=p)
for(jj in 1:p){
  for(kk in 1:p){
    SigmaX[jj,kk] <- .5^abs(jj-kk)
  }
}
eo <- eigen(SigmaX)
SigmaXsqrt <- tcrossprod(tcrossprod(eo$vec, diag(eo$val^.5)), eo$vec)

# generate data -------------
X <- tcrossprod(matrix(rnorm(n*p), nrow=n), SigmaXsqrt)

beta <- matrix(0, nrow=p, ncol=J*K)
temp <- sample(1:p, 10)

# predict affect joint probabilities -------------
for(j in 1:6){
  beta[temp[j],] <- runif(6, -3, 3)
}
# predictors affect marginal probabilities only ---
for(j in 7:10){
  temp1 <- runif(4, -3, 3)
  beta[temp[j],] <- c(-temp1[4] + temp1[3] + temp1[1], temp1[1], temp1[2],
                      temp1[3], temp1[4], -temp1[1]+ temp1[4] + temp1[2])
}

lleval <- exp(crossprod(t(X), beta))
Pmat <- lleval/tcrossprod(rowSums(lleval), rep(1, J*K))
Ymat <- matrix(0, nrow=n, ncol=J*K)
Y <- list(NA)
Y[[1]] <- rep(0, n)
Y[[2]] <- rep(0, n)
refClasses <- rbind(c(1:J, 1:J), c(rep(1, J), rep(2, J)))
for(k in 1:n){
  Ymat[k,] <- rmultinom(1, 1, Pmat[k,])
  Y[[1]][k] <- refClasses[1,which(Ymat[k,]==1)]
  Y[[2]][k] <- refClasses[2,which(Ymat[k,]==1)]
}

# ----------------------------------------
# Fit model with cross-validation
# ----------------------------------------
modfit <- BvCat.cv(X, Y, ngamma = 20,
                   lambda.vec = 10^seq(-4, 0, length=5),
                   nfolds = 5, delta = .01, standardize = TRUE,
                   tol = 1e-8,  quiet = FALSE, inner.quiet = TRUE)

# ---------------------------------------
# CV errors
# ---------------------------------------
apply(modfit$errs.joint, c(1,2), mean) # default
apply(modfit$deviance, c(1,2), mean)

# -----------------------------------------------------
# Coefficients at tuning parameter pair selected by CV
# -----------------------------------------------------
temp.coef <- BvCat.coef(modfit, type="matrix")
temp.coef.tensor <- BvCat.coef(modfit, type="tensor")
temp.coef.untuned <- BvCat.coef(modfit, lambda = modfit$lambda.vec[1], gamma = modfit$gamma.vec[10], type="matrix")

ntest <- 1
Xtest <- tcrossprod(matrix(rnorm(ntest*p), nrow=ntest),SigmaXsqrt)
temp.predict <- BvCat.predict(Xtest, modfit, type="class")
temp.predict.probs <- BvCat.predict(Xtest, modfit, type="probabilities")
# first dimension of temp.predict.probs$preds length ntest, second J, and third K

# ----------------------------------------
# Fit model with no cross-validation
# ----------------------------------------
modfit.noCV <- BvCat.cv(X, Y, ngamma = 20,
                   lambda.vec = 10^seq(-1, -4, length=5),
                   nfolds = NULL, delta = .01, standardize = TRUE,
                   tol = 1e-8,  quiet = TRUE, inner.quiet = TRUE)

# temp.coef <- BvCat.coef(modfit.noCV, type="matrix") # returns errror
temp.coef.noCV <- BvCat.coef(modfit.noCV, lambda = modfit$lambda.vec[1], gamma = modfit$gamma.vec[10], type="matrix")

}


### Seq-Gen output analysis
### CIR Project
### Advisors: Steve Freedberg, Matthew Richey
### Code by: Suzie Hoops

#######installing packages:
if (!require('seqinr')) {
	install.packages('seqinr', repos="http://cran.rstudio.com/")
	library('seqinr')
}
if (!require('mosaic')) {
	install.packages('mosaic', repos="http://cran.rstudio.com/")
	install.packages('mosaicData', repos="http://cran.rstudio.com/")
	library('mosaic')
}

printf <- function(...) cat(sprintf(...))

##################################################
# We want to compare the two individuals to find a Hamming
# distance between them. That is, how many base pairs differ
# between the two sequences.

# To do this, we must compare each base pair, one at a time.
# Let's make a function for comparing the pieces of the string:
HammingDistance <- function (x, y) {
  # note that the parameters x and y should be
  counter <- 0   # to track the number of base pairs different
  index <- 1     # to keep track of indices in for loop
  xVector <- strsplit(x, "")[[1]]
  yVector <- strsplit(y, "")[[1]]
  for (i in xVector) {
    if (i != yVector[index]) {
      counter <- counter + 1
    }
    index <- index + 1
  }
  return(counter)    # returns number of base pairs that differ
}

HammingDistanceTwoSequences <- function (file1, file2) {
  x <- LoadFileIntoString(file1)
  y <- LoadFileIntoString(file2)
  distance <- HammingDistance(x, y)
  print(distance)
}

LoadFileIntoString <- function (fileName) {
  return(readChar(fileName, file.info(fileName)$size))
}

LoadDataFromFile <- function(fname) {
  ##################################################
  # Generalizing to Larger Files
  # The above code works for a file of only two individuals, but
  # we wish to generalize this so that it can be used for multiple
  # pairs of individuals and store the appropriate data.

  # Note that for now, we will assume that all sequences in a
  # single file have the same length.

  ### First Steps
  # read in the data:
  data <- read.fasta(file=fname, as.string=TRUE)

  # get the number of sequences included in the data
  len <- length(data)

  # create a vector of every other integer up to len for the loop
  list <- seq(1, len, 2)

  # store the original names of the sequences:
  orig_names <- names(data)

  ##################################################
  # We create a for loop to cycle through the pairs and compare
  # each one. The loop will record its findings in a list called `out`.

  # out is initialized with fillers
  out <- seq(1:(len/2))

  # print(data)
  # printf("end\n")

  for (i in list) {
    names(data)[i] <- "indiv1"
    names(data)[i+1] <- "indiv2"
    length <- nchar(data$indiv1[1])
    taxon1 <- substring(data$indiv1[1], seq(1,length,1), seq(1,length,1))
    taxon2 <- substring(data$indiv2[1], seq(1,length,1), seq(1,length,1))
    index <- (i-1)/2 + 1
    out[index] <- HammingDistance(taxon1, taxon2)
  }

  # Now "out" is filled with Hamming distances of all pairs

  ##################################################
  # Simple Statistics from the data:
  avgOfRange <- mean(out)      # average
  minOfRange <- min(out)       # minimum of range
  maxOfRange <- max(out)       # maximum of range
  percent <- (avgOfRange / len)

  printf("avg=%d\n", avgOfRange)
  printf("min=%d\n", minOfRange)
  printf("max=%d\n", maxOfRange)
  printf("percent=%f\n", percent)

  printf("start data\n")
  print(out)    # desired output
}

EstimateGenerations <- function(genlength, percent) {
  ##################################################
  ##################################################
  # Estimating Generations:
  # Assume 2% per million years (standard for cytochrome B)
  # mutation rate. This allows us to calculate a likely divergence
  # time, from which we can estimate generations:

  # divergence time in million years
  divtime <- percent/0.02
  printf("divtime=%d\n", divtime)

  # number of generations (used for seq gen parameters)
  gen <- divtime*1000000/genlength
  printf("gen=%d\n", gen)
}

PrintUsage <- function() {
  write("usage: Rscript hamdis.r <command> <args>", stdout())
  write("commands:", stdout())
  write("  estimate <generation length> <percentage>", stdout())
  write("  calculate <filename> <something else>", stdout())
  write("  distance-between <filename> <filename>", stdout())
  quit()
}

args <- commandArgs(trailingOnly = TRUE)
if (length(args) != 3) {
  PrintUsage()
}

command <- args[1]
if (command == "estimate") {
  genlength <- as.numeric(args[2])
  percent <- as.numeric(args[3])
  EstimateGenerations(genlength, percent)
} else if (command == "calculate") {
  filename <- args[2]
  other <- args[3]
  LoadDataFromFile(filename)
} else if (command == "distance-between") {
  xfilename <- args[2]
  yfilename <- args[3]
  HammingDistanceTwoSequences(xfilename, yfilename)
} else {
  PrintUsage()
}


suppressMessages(library(plyr))
suppressMessages(library(rmutil))
suppressWarnings(suppressMessages(library(rtracklayer)))
suppressMessages(library(dplyr))

args = commandArgs(trailingOnly = TRUE)
# args[1] should be the path to a file in which the allele.imbalance function is defined: allele.imbalance(rna, dna, rna.err, dna.err)
source(args[1])
# import dna and rna counts, which should be ready for input into allele_imbalance.r
dna = read.csv(gzfile(args[2]))
rna = read.csv(gzfile(args[3]))
# import gene info from gencode
genes = readGFF(args[4])

# calculate error rates
err.rate = function(ref, alt, err){
  rate = (sum(err))/sum(ref+alt+err)
  rate*(3/2)
}

# get dna and rna errors for allele_imbalance.r
message("Calculating dna and rna error rates...")
dna.err = err.rate(dna$ref.matches, dna$alt.matches, dna$errors)
rna.err = err.rate(rna$ref.matches, rna$alt.matches, rna$errors)

# NOW, we can finally call allele.imbalance()
# note that dna and rna are data frames that need to have these columns:
# 	ref.matches (ie ref_allele_count),
# 	N (total allele count - ref+alt),
# 	genotype.error (ie 10^(-GQ/10) - only appears in dna DF),
# 	rsID (<chr>:<pos>_<allele1>/<allele2>),
# 	gene (name of gene that this SNP appears in, as rnaovided by gencode),
#   start (position of SNP)
dna = dna[c('ref.matches', 'N', 'genotype.error', 'rsID', 'gene', 'start')]
rna = rna[c('ref.matches', 'N', 'rsID', 'gene', 'start')]
# call allele_imbalance and store the result in res
message("Calling allele.imbalance on ", nrow(dna), " SNPs...")
res = as.data.frame(allele.imbalance(rna, dna, rna.err, dna.err))

# rename col 'd' to 'a', since it represents estimates of allelic imbalance
colnames(res)[which(names(res) == "d")] = "a"
# convert gene col from type factor to type char so dplyr is happy
res$gene = as.character(res$gene)
# add gene names to res. it only has gene_id right now
message("Adding gene names to ", nrow(res)," genes...")
res = left_join(res, unique(genes[, c("gene_name", "gene_id")]), by = c("gene"="gene_id"))
message("Writing ", nrow(res), " genes to file...\n")
write.csv(res, stdout(), row.names = F)


##Generate random numbers that follows uniform distribution

Uniform<-function(GD, CropName, CultivarID, GenotypeFileName, ParameterProperty, ParameterAddress, TotalParameterNumber, NumberOfModelRun, RoundOfGLUE, GLUEFlag)
{

#(1)Read default values.
eval(parse(text=paste('GenotypeFilePath="',GD,'/',GenotypeFileName,'.CUL"',sep = '')));
ReadLine<-readLines(GenotypeFilePath, n=-1);
#print(ReadLine);
GenotypeFile<-as.character(ReadLine);
CultivarID<-paste('^',CultivarID, sep="");
LineNumber<-grep(pattern=CultivarID, GenotypeFile);
OldLine<-GenotypeFile[LineNumber];#Get the line according to the line number.

if(CropName != "SC")
{
  Step=6;
  ValueStart<-(38-Step);
  ValueEnd<-(42-Step);
} else
{
  Step=15;
# chp changed 34 -> 37;  47 -> 51
  ValueStart<-(37-Step);
  ValueEnd<-(51-Step);
}

DefaultValue<-c();

for (i in 1:TotalParameterNumber)
{
ValueStart<-ValueStart+Step;
ValueEnd<-ValueEnd+Step;

ParameterValue<-as.numeric(substr(OldLine, ValueStart, ValueEnd));
DefaultValue<-cbind(DefaultValue, ParameterValue);
}

#Read the initial genotype file so as to read the default values for each parameters.

#(2) Read parameter set that have the maximum likelihood values when first round of GLUE is finished.
if ((GLUEFlag==1)&(RoundOfGLUE==2))
{
eval(parse(text = paste('PosteriorDistribution1<-read.table("',OD,
'/PosteriorDistribution_1.txt",header=TRUE,comment.char="")',sep="")));

MaximumProbability<-as.numeric(PosteriorDistribution1["MaxProbability", ]);
#print(MaximumProbability);
}

#(3) Generate random numbers
ParameterMatrix<-c();
ParameterAddress<-ParameterAddress+1;

for (i in 1:TotalParameterNumber)
{
#Generate uniform random values for P[i], i is the total number of parameters involved.
Flag<-ParameterProperty[ParameterAddress, 'Flag'];

if (GLUEFlag==1)
{
  if (RoundOfGLUE==1)
  {
    if (Flag==1)
    {
    Minimum=ParameterProperty[ParameterAddress, 'Minimum'];
    Maximum=ParameterProperty[ParameterAddress, 'Maximum'];
    } else if (Flag==0)
    {
    Minimum=DefaultValue[i];
    Maximum=DefaultValue[i];
    } else if (Flag==2)
    {
    Minimum=DefaultValue[i];
    Maximum=DefaultValue[i];
    }
  } else if (RoundOfGLUE==2)
  {
    if(Flag==2)
    {
    Minimum=ParameterProperty[ParameterAddress, 'Minimum'];
    Maximum=ParameterProperty[ParameterAddress, 'Maximum'];
    } else if (Flag==0)
    {
    Minimum=DefaultValue[i];
    Maximum=DefaultValue[i];
    } else if (Flag==1)
    {
    Minimum=MaximumProbability[i];
    Maximum=MaximumProbability[i];
    }
  }
} else if (GLUEFlag==2)
{
    if (Flag==1)
    {
    Minimum=ParameterProperty[ParameterAddress, 'Minimum'];
    Maximum=ParameterProperty[ParameterAddress, 'Maximum'];
    } else if (Flag==0)
    {
    Minimum=DefaultValue[i];
    Maximum=DefaultValue[i];
    } else if (Flag==2)
    {
    Minimum=DefaultValue[i];
    Maximum=DefaultValue[i];
    }
} else if (GLUEFlag==3)
{
     if (Flag==0)
    {
    Minimum=DefaultValue[i];
    Maximum=DefaultValue[i];
    } else if (Flag==1)
    {
    Minimum=DefaultValue[i];
    Maximum=DefaultValue[i];
    } else if (Flag==2)
    {
    Minimum=ParameterProperty[ParameterAddress, 'Minimum'];
    Maximum=ParameterProperty[ParameterAddress, 'Maximum'];
    }
}

GenerateParameter<-runif(NumberOfModelRun,min=Minimum,max=Maximum);
MatrixGeneratedParameter<-matrix(GenerateParameter, nrow=NumberOfModelRun, ncol=1, byrow=T);
ParameterMatrix<-cbind(ParameterMatrix, MatrixGeneratedParameter);

ParameterAddress<-ParameterAddress+1;
}

#print(ParameterMatrix);

#ParameterMatrix<-ifelse(ParameterMatrix>=999,999,ParameterMatrix);
#Set the values of some parameters such as G2 that are great than 1000 to 999, otherwise, the model will stop running.

ParameterMatrix<-ifelse(is.na(ParameterMatrix), 0, ParameterMatrix);
#If the values of some parameters are NAs which were generated by missed parameter values in the genotype file,
#they were set as zeros.

#print(ParameterMatrix);

return(ParameterMatrix);
}


# only if you install a Bioconductor package for the first time
# source("http://www.bioconductor.org/biocLite.R")
# # else
# library("BiocInstaller")
# biocLite("PAA", dependencies=TRUE)

 #library(PAA)

library(ARPPA) #this is the my own package to run analysis

#now start reading the text exported data
#this is the batch done on 10/08/2015
datapath<-system.file("extdata", package="ARPPA")
targets <- list.files(system.file("extdata", package="ARPPA"),
	 pattern = "targets_text_Batch1", full.names=TRUE)
elist2<-importTextData(dataFilePath=datapath, targetFile=targets, start.data=51, nrows.data=18803-53,
			start.control=18803, nrows.control=23286,aggregation="geoMean",
			as.is=TRUE, header=TRUE,sep="\t",na.strings="", quote="")
elist2$array.type<-"ProtoArray"
#===>background correction
library(limma)

elist2 <- backgroundCorrect(elist2, method="normexp",
 normexp.method="saddle")

 #now we need to rearrange the control and testing proteins to background correct control
 #it works this way that background correction only working on elist$E
 #so we have to do the rearrangement
 elist_c<-elist2
 elist_c$E<-elist2$C
 elist_c$Eb<-elist2$Cb
 #this is good enough, we don't have to change elistC$C, since other fields are not touched
 elist_c<-backgroundCorrect(elist_c, method="normexp",
 normexp.method="saddle")

 #now change it back
 elist2$C<-elist_c$E
 elist2$Cb<-elist_c$Eb
 ##=====>end of background correction

 indices<-grep("HumanIgG", elist2$cgenes$Name)
 elist2$cgenes[indices,]

###calling the PAA to do the normalization
library(PAA)

elist_norm<-normalizeArrays(elist=elist2, method="rlm",
  cyclicloess.method="fast", control ="HumanIgG")

 #now we have everything, we just need to rewrite the data into a format
 #that can be used by linear regression
 sampleNames<-colnames(elist_norm$E)
 geneNames<-elist_norm$genes[,"Name"]

 #now we need to split the data into two pieces,
 #first
 dtFrame<-c()
 for(i in 1:length(sampleNames))
 {
	Gene<-geneNames
	Sample<-rep(sampleNames[i],length(geneNames))
	MFI<-elist_norm$E[,i]

	temp<-data.frame(Gene,Sample,MFI)
	if(i==1)
	{
		dtFrame<-temp
	} else
	{
		dtFrame<-rbind(dtFrame, temp)
	}
 }

 mdl<-lm(MFI~Gene*Sample, dtFrame)


# mpiexec -np 4 ./Rscript anosimMPI_22_09_2015.r "SPE_Lagoon16S_C10.csv" TRUE "Factors_Lagoon16S.csv" 1 "/home/varsos/R-3.1.1/Datasets/Christina_dataset/" 9999 "bray"

rm(list=ls())

# Initial Parameters given by the user
args <- commandArgs(trailingOnly = TRUE)
dataMatrix <- args[1] # The name of the csv file.
transposition <- as.logical(args[2]) # Choose to transpose the matrix (TRUE) or not (FALSE).
groupingFactor <- args[3] # The name of the factor file for grouping observations.
SelectFactor <- as.numeric(args[4]) # Choose the desired factors's column.
datasetPath <- args[5] # The directory (path) where the datasets are stored.
permutations <- as.numeric(args[6])
distance <- args[7]

# Start the clock
fullProgramTimer <- proc.time()

setwd(datasetPath)

SPE.dist <- read.csv(dataMatrix, header = TRUE, row.names = 1, sep = ",")
Factors <- read.csv(groupingFactor, header = TRUE, row.names = 1, sep = ",")

if(transposition) {
  dat <- t(SPE.dist)
} else if (transposition != TRUE) {
  dat <- SPE.dist
} else {
  stop("Wrong choice. Choose to transpose the matrix (TRUE) or not (FALSE).")
}

if((SelectFactor <= 0) || (SelectFactor > ncol(Factors))) {
  stop("Wrong choice of Factors, transcends available Factors choices.")
}

grouping <- Factors[, SelectFactor]

# load libraries
library(vegan)
library(pbdMPI, quiet = TRUE)

init()

# TP: Get the size of the cluster
processors <- comm.size()
myrank <- comm.rank()

if (inherits(dat, "dist")) {
  x <- dat} else if (is.matrix(dat) && nrow(dat) == ncol(dat) && all(dat[lower.tri(dat)] ==  t(dat)[lower.tri(dat)])) {
    x <- dat
    attr(x, "method") <- "user supplied square matrix"
  } else {
    x <- vegdist(dat, method = distance)
  }

if (any(x < -sqrt(.Machine$double.eps)))
  warning("some dissimilarities are negative -- is this intentional?")

sol <- c(call = match.call(definition = function(dat, grouping, permutations, distance)NULL, quote(anosim(dat, grouping, permutations, distance))))
grouping <- as.factor(grouping)
matched <- function(irow, icol, grouping) {
  grouping[irow] == grouping[icol]
}
x.rank <- rank(x)
N <- attr(x, "Size")
div <- length(x)/2
irow <- as.vector(as.dist(row(matrix(nrow = N, ncol = N))))
icol <- as.vector(as.dist(col(matrix(nrow = N, ncol = N))))
within <- matched(irow, icol, grouping)
aver <- tapply(x.rank, within, mean)

statistic <- -diff(aver)/div
cl.vec <- rep("Between", length(x))
take <- as.numeric(irow[within])
cl.vec[within] <- levels(grouping)[grouping[take]]
cl.vec <- factor(cl.vec, levels = c("Between", levels(grouping)))

if (permutations) {

  if 	(myrank != (processors-1)) {
    perm <- rep(0, ceiling(permutations/processors))
  } else perm <- rep(0, permutations - ( (processors-1) * ceiling(permutations/processors)))

  for (i in 1:(permutations/processors)) {
    take <- permute::shuffle(N)
    cl.perm <- grouping[take]
    tmp.within <- matched(irow, icol, cl.perm)
    tmp.ave <- tapply(x.rank, tmp.within, mean)
    perm[i] <- -diff(tmp.ave)/div
  }

  if (myrank == 0) {print("Number of permutations per processor:")}

  print(length(perm))
  n.permsum <- sum(perm >= statistic)

  all.permsum <- reduce(n.permsum, op='sum')

  if (myrank == 0) {
    p.val <- (1 + all.permsum)/(1 + permutations)

    print("p.val = ")
    print(p.val)

    sol <- as.call(list(quote(anosim), quote(mat), quote(Factors[, SelectFactor]),
                        permutations = permutations, method = distance))

    sol$call <- as.call(list(quote(anosim), quote(mat), quote(Factors[, SelectFactor]),
                             permutations = permutations, method = distance))
    sol$signif <- p.val
    sol$perm <- perm
    sol$permutations <- permutations
    sol$statistic <- as.numeric(statistic)
    sol$class.vec <- cl.vec
    sol$dis.rank <- x.rank
    sol$dissimilarity <- attr(x, "method")
  }

}
class(sol) <- "anosim"

# comm.print("permutations", rank.print = 0)
# comm.print(permutations, rank.print = 0)
# comm.print("method", rank.print = 0)
# comm.print(distance, rank.print = 0)

comm.print(sol)

# Stop the clock
comm.print("Full program execution time for each processor",rank.source = 0)
comm.print(proc.time() - fullProgramTimer, all.rank=T)

# Results
# comm.print("Significance:", rank.source = 0)
# comm.print(sol[[2]], rank.source = T)

# comm.print("Statistic R", rank.source = 0)
# comm.print(sol[[5]], rank.source = T)

# comm.print("Factors", rank.source = 0)
# comm.print(length(sol[[6]]), rank.source = T)

# comm.print("Community", rank.source = 0)
# comm.print(length(sol[[7]]), rank.source = T)

# comm.print("Final result's size", rank.source = 0)
# comm.print((object.size(sol)/(1024^2)), all.rank = T)
finalize()


# Run posterior forecasts to make predictions

# Set up
source('2020-08-31-jsa-type-v2-ch2/02-model/init.r')

# Parameters
set.seed(2020) # for reproducibility
ftime <- model_params$fc

# Script

# Load data
files <- dir(dir_model_folder, pattern = 'count_info.data.R', full.names = TRUE)
data <- read_rdump(files)

# Load model
load(paste0(dir_model_folder, "fit.data"))
zips <- fit; rm(fit)

# Posterior simulations
print(paste0(Sys.time(), " --- Making posterior simulation"))
allsim <- mclapply(1:1000, mc.cores = 1, function(ii) {
    posterior_sim(data = data, model = zips)
})

# Save posterior simulations
save(allsim, file = paste0(dir_model_folder, "post.data"))
rm(allsim) # clean memory

# Simulate the forecast
print(paste0(Sys.time(), " --- Making posterior forecasts"))
forecast <- mclapply(1:1000, mc.cores = 1, function(ii) {
	posterior_forecast(data = data, ftime = ftime, model = zips)
})

# Save forecast
save(forecast, file = paste0(dir_model_folder, "forecast.data"))
rm(data, zips, forecast) # clean memory


#' Compute relative distances between intervals.
#'
#' @param x [ivl_df]
#' @param y [ivl_df]
#' @param detail report relative distances for each `x` interval.
#'
#' @family interval statistics
#'
#' @return
#' If `detail = FALSE`, a [ivl_df] that summarizes
#' calculated `.reldist` values with the following columns:
#'
#'   - `.reldist` relative distance metric
#'   - `.counts` number of metric observations
#'   - `.total` total observations
#'   - `.freq` frequency of observation
#'
#' If `detail = TRUE`, the `.reldist` column reports the relative
#' distance for each input `x` interval.
#'
#' @template stats
#'
#' @seealso \url{http://bedtools.readthedocs.io/en/latest/content/tools/reldist.html}
#'
#' @examples
#' genome <- read_genome(valr_example('hg19.chrom.sizes.gz'))
#'
#' x <- bed_random(genome, seed = 1010486)
#' y <- bed_random(genome, seed = 9203911)
#'
#' bed_reldist(x, y)
#'
#' bed_reldist(x, y, detail = TRUE)
#'
#' @export
bed_reldist <- function(x, y, detail = FALSE) {
  x <- check_interval(x)
  y <- check_interval(y)

  # establish grouping with shared groups (and chrom)
  groups_xy <- shared_groups(x, y)
  groups_xy <- unique(as.character(c("chrom", groups_xy)))
  groups_vars <- rlang::syms(groups_xy)

  # type convert grouping factors to characters if necessary and ungroup
  x <- convert_factors(x, groups_xy)
  y <- convert_factors(y, groups_xy)

  x <- group_by(x, !!! groups_vars)
  y <- group_by(y, !!! groups_vars)

  grp_indexes <- shared_group_indexes(x, y)

  res <- dist_impl(x, y,
                   grp_indexes$x,
                   grp_indexes$y,
                   distcalc = "reldist")

  if (detail) return(res)

  res[[".reldist"]] <- floor(res[[".reldist"]] * 100) / 100
  nr <- nrow(res)
  res <- group_by(res, .reldist)
  res <- summarize(
    res,
    .counts = n(),
    .total = nr,
    .freq = .counts / .total
  )
  res
}


# Converts a structure file to SNAPP format using the first SNP from
# each locus. Output is named SNAPP.nex and the mutation rates (U and
# V) are printed.

# USAGE:
# Place structure file and this script in a directory, and set the R
# current working directory to be the same. Then type the following
# commands, where "file" is the name of your structure file:
# source("convert_snapp.r")
# convert_snapp("file")

convert_snapp <- function(file) {
	file <- file

	x <- read.table(file, sep = "\t")
	# remove the population identification column or not
	if (is.na(x[1, 2]) == TRUE) {
		x <- cbind(x[,1], x[,3:ncol(x)])
	}

	# take first SNP from each locus
	list.loci <- unique(as.numeric(x[1,2:ncol(x)]))
	matches.loci <- c(1, match(list.loci, x[1,]))
	x <- x[,matches.loci]

	x <- x[2:nrow(x),]

	bi_allelic <- c()
	for(a in 2:ncol(x)) {			#determine which SNPs are bi-allelic

		bi <- x[,a]
		bi <- unique(bi)
		bi <- bi[ bi != 0 ]
		bi <- length(bi)
		bi_allelic <- c(bi_allelic, bi)

	}

	bi_allelic <- bi_allelic == 2

	x2 <- x[,bi_allelic]

	###determine possible alleles of each SNP
	allele.a <- c()
	allele.b <- c()
	for(b in 1:ncol(x2)) {

		alleles <- unique(x2[, b])
		alleles <- alleles[ alleles != 0 ]
		allele.a <- c(allele.a, alleles[1])
		allele.b <- c(allele.b, alleles[2])

	}
	c <- c()
	d <- c()
	n.inds <- nrow(x2) / 2

	file <- c()
	individual <- c()
	for(c in 1:n.inds) {

		indiv.a <- c*2 - 1
		indiv.b <- c*2
		individual <- c(individual, as.character(x2[indiv.a, 1]))
		indiv2 <- c()

			if(x2[indiv.a,2] == x2[indiv.b, 2] & x2[indiv.a,2] != 0 & x2[indiv.a,2] == allele.a[2]){indivi <- 0}
			if(x2[indiv.a,2] == x2[indiv.b, 2] & x2[indiv.a,2] != 0 & x2[indiv.a,2] == allele.b[2]){indivi <- 2}
			if(x2[indiv.a,2] != x2[indiv.b, 2]){indivi <- 1}
			if(x2[indiv.a,2] == 0){indivi <- "-"}

		for(d in 3:ncol(x2)){

			if(x2[indiv.a,d] == x2[indiv.b, d] & x2[indiv.a,d] != 0 & x2[indiv.a,d] == allele.a[d]){indiv <- 0}
			if(x2[indiv.a,d] == x2[indiv.b, d] & x2[indiv.a,d] != 0 & x2[indiv.a,d] == allele.b[d]){indiv <- 2}
			if(x2[indiv.a,d] != x2[indiv.b, d]){indiv <- 1}
			if(x2[indiv.a,d] == 0){indiv <- "-"}
			indivi <- paste(indivi, indiv, sep="")

		}

		file <- c(file, indivi)

	}
	output <- cbind(individual, file)
	header <- list()
	header[[1]] <- "#NEXUS"
	header[[2]] <- ""
	header[[3]] <- "Begin data;"
	header[[4]] <- paste("	Dimensions ntax=", length(individual), " nchar=", nchar(file[1]), ";", sep="")
	header[[5]] <- paste("	Format datatype=standard symbols=", '"', "012", '"',
		" missing=-;", sep="")
	header[[6]] <- "	Matrix"
	header[[7]] <- "	;"
	header[[8]] <- "End;"
	write(header[[1]], file="SNAPP.nex",ncolumns=1)
	write(header[[2]], file="SNAPP.nex",ncolumns=1, append=TRUE)
	write(header[[3]], file="SNAPP.nex",ncolumns=1, append=TRUE)
	write(header[[4]], file="SNAPP.nex",ncolumns=1, append=TRUE)
	write(header[[5]], file="SNAPP.nex",ncolumns=1, append=TRUE)
	write(header[[6]], file="SNAPP.nex",ncolumns=1, append=TRUE)
	for(a in 1:nrow(output)) {
		write(output[a,], file="SNAPP.nex", ncolumns=2, sep="\t",append=TRUE)
	}
	write(header[[7]], file="SNAPP.nex",ncolumns=1, append=TRUE)
	write(header[[8]], file="SNAPP.nex",append=TRUE)

	mutate("SNAPP.nex")

}

# input is snapp file
mutate <- function(x) {
	#obtain number of rows of data
	y <- read.table(x, skip=3, nrows=1)
	y <- as.character(y[1,2])
	y <- strsplit(y, "=")
	y <- y[[1]]
	y <- y[2]
	y <- strsplit(y, ";")
	y <- y[[1]]
	y <- y[1]
	y <- as.numeric(y)

	x <- read.table(x, skip=6, nrows=y)
	x <- as.matrix(x[,2])
	x <- as.vector(x[,1])
	for(a in 1:length(x)) {
		if(a == 1) { y <- x[a] }
		if(a != 1) { y <- paste(y, x[a], sep="")}
		}
	y <- strsplit(y, "")
	y <- y[[1]]

	x1 <- as.vector(table(y)[2])
	x2 <- as.vector(table(y)[3])
	x3 <- as.vector(table(y)[4])
	u <- x1 + 0.5 * x2
	v <- x3 + 0.5 * x2
	w <- u + v
	u <- u / w
	v <- v / w
	u2 <- 1 / (2 * u)
	v2 <- 1 / (2 * v)
	print(paste("U = ", u2, sep=""))
	print(paste("V = ", v2, sep=""))
}


library(RODBC)
library(mgcv)

AFSC=odbcConnect("AFSC","sbarb","sbarb$1011")

## Survey Age Data

Age=sqlQuery(AFSC, "SELECT RACEBASE.SPECIMEN.REGION,
  TO_CHAR(RACEBASE.HAUL.START_TIME, 'yyyy') AS YEAR,
  RACEBASE.SPECIMEN.CRUISE,
  RACEBASE.HAUL.VESSEL,
  RACEBASE.SPECIMEN.HAUL,
  RACEBASE.SPECIMEN.SPECIES_CODE,
  RACEBASE.SPECIMEN.LENGTH,
  RACEBASE.SPECIMEN.SEX,
  RACEBASE.SPECIMEN.WEIGHT,
  RACEBASE.SPECIMEN.MATURITY,
  RACEBASE.SPECIMEN.AGE,
  RACEBASE.HAUL.END_LONGITUDE,
  RACEBASE.HAUL.HAUL_TYPE,
  RACEBASE.HAUL.PERFORMANCE,
  RACEBASE.SPECIMEN.SPECIMEN_SAMPLE_TYPE,
  RACEBASE.SPECIMEN.SPECIMENID,
  RACEBASE.SPECIMEN.BIOSTRATUM
FROM RACEBASE.SPECIMEN
INNER JOIN RACEBASE.HAUL
ON RACEBASE.SPECIMEN.HAULJOIN                 = RACEBASE.HAUL.HAULJOIN
AND RACEBASE.HAUL.CRUISEJOIN                  = RACEBASE.SPECIMEN.CRUISEJOIN
WHERE RACEBASE.SPECIMEN.REGION                = 'AI'
AND RACEBASE.SPECIMEN.SPECIES_CODE            = 21740
AND RACEBASE.HAUL.HAUL_TYPE                   = 3
AND RACEBASE.HAUL.PERFORMANCE                >= 0
AND TO_CHAR(RACEBASE.HAUL.START_TIME, 'yyyy') > 1977
ORDER BY TO_CHAR(RACEBASE.HAUL.START_TIME, 'yyyy')")

Age_w<-subset(Age,Age$END_LONGITUDE > 0 | Age$END_LONGITUDE < -170)
Age_10<-subset(Age,Age$YEAR==2010)
Age_10w<-subset(Age_w,Age_w$YEAR==2010)

Age_w<-subset(Age_w,is.na(Age_w$AGE)==F)
Age_w$AGE1<-Age_w$AGE
Age_w$AGE1[Age_w$AGE1>=15]=15
Age_w$END_LONG<-Age_w$END_LONGITUDE
Age_w$END_LONG[Age_w$END_LONGITUDE<0]<- -Age_w$END_LONGITUDE[Age_w$END_LONGITUDE<0]
Age_w$END_LONG[Age_w$END_LONGITUDE>0]<- Age_w$END_LONGITUDE[Age_w$END_LONGITUDE>0]+ (180-Age_w$END_LONGITUDE[Age_w$END_LONGITUDE>0])

AGE<-aggregate(list(FREQ=Age_w$LENGTH),by=list(LENGTH=round(Age_w$LENGTH/10,-1),AGE=Age_w$AGE1,YEAR=Age_w$YEAR),FUN=length)

years<-unique(AGE$YEAR)

GRID<-expand.grid(YEAR=years,LENGTH=seq(10,max(AGE$LENGTH),10))
AGE1<-merge(GRID,AGE,all=T)
AGE1$FREQ[is.na(AGE1$FREQ)==T]=0

Total_A<-aggregate(list(Total=AGE1$FREQ),by=list(YEAR=AGE1$YEAR,LENGTH=AGE1$LENGTH),FUN=sum)

Total_B<-merge(AGE1,Total_A,all=T)
Total_B$Prob<-Total_B$FREQ/Total_B$Total
Total_B$Prob[Total_B$LENGTH==10&is.na(Total_B$Prob)==T]<-1.0
Total_B$AGE[Total_B$LENGTH==10&is.na(Total_B$AGE)==T]<-1.0

Total_B[410,]<- c(1980,0,1,1,0,1)
Total_B[411,]<- c(1983,0,1,1,0,1)
Total_B[412,]<- c(1986,0,1,1,0,1)
Total_B[413,]<- c(1991,0,1,1,0,1)
Total_B[414,]<- c(1994,0,1,1,0,1)
Total_B[415,]<- c(1997,0,1,1,0,1)
Total_B[416,]<- c(2000,0,1,1,0,1)
Total_B[417,]<- c(2004,0,1,1,0,1)
Total_B[418,]<- c(2006,0,1,1,0,1)
Total_B[419,]<- c(2004,90,15,1,0,1)

Total_B[121,]<- c(1986,80,14 ,1,0,1)
Total_B[123,]<- c(1991,20,1,1,0,1)
Total_B[84,]<- c(1983,80,14,1,0,1)
Total_B[2,]<- c(1980,20,1,1,0,1)
Total_B<-subset(Total_B,is.na(Total_B$AGE)==F)

Total_B<- Total_B[order(Total_B$YEAR,Total_B$LENGTH),]

##Length Data

Length=sqlQuery(AFSC,"SELECT RACEBASE.LENGTH.REGION,
  TO_CHAR(RACEBASE.HAUL.START_TIME, 'yyyy') AS YEAR,
  RACEBASE.LENGTH.CRUISE,
  RACEBASE.LENGTH.VESSEL,
  RACEBASE.LENGTH.HAUL,
  RACEBASE.LENGTH.SPECIES_CODE,
  RACEBASE.LENGTH.SEX,
  RACEBASE.LENGTH.LENGTH,
  RACEBASE.LENGTH.FREQUENCY,
  RACEBASE.HAUL.END_LONGITUDE,
  RACEBASE.HAUL.GEAR,
  RACEBASE.HAUL.STRATUM,
  RACEBASE.HAUL.HAUL_TYPE
FROM RACEBASE.LENGTH
INNER JOIN RACEBASE.HAUL
ON RACEBASE.LENGTH.CRUISEJOIN                 = RACEBASE.HAUL.CRUISEJOIN
AND RACEBASE.LENGTH.HAULJOIN                  = RACEBASE.HAUL.HAULJOIN
WHERE RACEBASE.LENGTH.REGION                  = 'AI'
AND RACEBASE.LENGTH.SPECIES_CODE              = 21740
AND TO_CHAR(RACEBASE.HAUL.START_TIME, 'yyyy') >= 1980
AND RACEBASE.HAUL.HAUL_TYPE                   = 3 ")

Length_w<-subset(Length,Length$END_LONGITUDE > 0 | Length$END_LONGITUDE < -170)
Length_w<-subset(Length_w,Length_w$YEAR!=1982)
Length_w<-subset(Length_w,Length_w$YEAR!=2010)

LENGTH=(data.frame(aggregate(list(FREQ=Length_w$FREQUENCY),by=list(LENGTH=Length_w$LENGTH/10,YEAR=Length_w$YEAR),FUN=sum)))
Total_L<-aggregate(list(Total=LENGTH$FREQ),by=list(YEAR=LENGTH$YEAR),FUN=sum)
Total_LB<-merge(LENGTH,Total_L,all=T)

## Survey WEIGHT at Age data

test<-gam(log(WEIGHT)~as.factor(YEAR)+s(LENGTH),gamma=1.4,data=Age_w)
new_data<-subset(Age_w,Age_w$YEAR==1980)
new_data$YEAR=1983
Age_w$WEIGHT[Age_w$YEAR==1980]<-exp(predict(test,newdata=new_data))

Weight<-subset(Age_w,is.na(Age_w$WEIGHT)==F)
WEIGHT<-aggregate(list(WEIGHT=Weight$WEIGHT),by=list(AGE=Weight$AGE1,YEAR=Weight$YEAR),FUN=mean)
grid=expand.grid(YEAR=sort(unique(WEIGHT$YEAR)),AGE=c(min(Age_w$AGE1):15))
WEIGHT_A<-merge(grid,WEIGHT,all=T)
test<-gam(log(WEIGHT)~as.factor(YEAR)+s(AGE,by=as.factor(YEAR)),gamma=1.4,data=subset(WEIGHT_A,is.na(WEIGHT_A$AGE)==F))
WEIGHT_A$pred<-exp(predict(test,newdata=WEIGHT_A))
WEIGHT_A$WEIGHT2<-WEIGHT_A$WEIGHT
WEIGHT_A$WEIGHT2[is.na(WEIGHT_A$WEIGHT2)==T]<-WEIGHT_A$pred[is.na(WEIGHT_A$WEIGHT2)==T]

GRID<-expand.grid(YEAR=c(1978:2011),AGE=c(1:15))
WEIGHT_B<-merge(GRID,WEIGHT_A,all=T)

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1978]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1980]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1979]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1980]

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1981]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1980|WEIGHT_B$YEAR==1983],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1980|WEIGHT_B$YEAR==1983]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1982]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1980|WEIGHT_B$YEAR==1983],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1980|WEIGHT_B$YEAR==1983]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1984]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1983|WEIGHT_B$YEAR==1986],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1983|WEIGHT_B$YEAR==1986]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1985]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1983|WEIGHT_B$YEAR==1986],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1983|WEIGHT_B$YEAR==1986]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1987]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1988]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1989]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1990]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1986|WEIGHT_B$YEAR==1991]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1992]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1991|WEIGHT_B$YEAR==1994],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1991|WEIGHT_B$YEAR==1994]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1993]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1991|WEIGHT_B$YEAR==1994],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1991|WEIGHT_B$YEAR==1994]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1995]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1994|WEIGHT_B$YEAR==1997],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1994|WEIGHT_B$YEAR==1997]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1996]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1994|WEIGHT_B$YEAR==1997],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1994|WEIGHT_B$YEAR==1997]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1998]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1997|WEIGHT_B$YEAR==2000],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1997|WEIGHT_B$YEAR==2000]),FUN=mean)$x
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1999]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==1997|WEIGHT_B$YEAR==2000],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==1997|WEIGHT_B$YEAR==2000]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2001]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2000|WEIGHT_B$YEAR==2002],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==2000|WEIGHT_B$YEAR==2002]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2003]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2004|WEIGHT_B$YEAR==2002],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==2002|WEIGHT_B$YEAR==2004]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2005]= aggregate(WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006|WEIGHT_B$YEAR==2004],by=list(WEIGHT_B$AGE[WEIGHT_B$YEAR==2004|WEIGHT_B$YEAR==2006]),FUN=mean)$x

WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2007]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2008]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2009]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2010]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]
WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2011]= WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==2006]

S_AGE_WEIGHT<-data.frame(matrix(ncol=15,nrow=length(unique(WEIGHT_B$YEAR))))
names(S_AGE_WEIGHT)<-c("YEAR","A2","A3" ,"A4","A5","A6","A7","A8","A9","A10","A11","A12","A13","A14","A15")
S_AGE_WEIGHT$YEAR<-c(1978:2011)

Years1<-c(1978:2011)
for( i in 1:length(Years1)){
S_AGE_WEIGHT[i,2:15]<-WEIGHT_B$WEIGHT2[WEIGHT_B$YEAR==Years1[i]][2:15]
}

## SUrvey Biomass Data

BIOMASS=sqlQuery(AFSC,"SELECT AI.BIOMASS_INPFC.SURVEY,
  AI.BIOMASS_INPFC.YEAR,
  AI.BIOMASS_INPFC.SUMMARY_AREA,
  AI.BIOMASS_INPFC.SPECIES_CODE,
  AI.BIOMASS_INPFC.AREA_BIOMASS,
  AI.BIOMASS_INPFC.BIOMASS_VAR,
  AI.BIOMASS_INPFC.AREA_POP,
  AI.BIOMASS_INPFC.POP_VAR
FROM AI.BIOMASS_INPFC
WHERE AI.BIOMASS_INPFC.SUMMARY_AREA != 799
AND AI.BIOMASS_INPFC.SPECIES_CODE    = 21740
ORDER BY AI.BIOMASS_INPFC.YEAR,
  AI.BIOMASS_INPFC.SUMMARY_AREA ")

BIO<-data.frame(aggregate(list(BIO=BIOMASS$AREA_BIOMASS,POP=BIOMASS$AREA_POP),by=list(YEAR=BIOMASS$YEAR),FUN=sum)  )

VAR<-data.frame(aggregate(list(BIO=BIOMASS$BIOMASS_VAR,POP=BIOMASS$POP_VAR),by=list(YEAR=BIOMASS$YEAR),FUN=sum)  )

survey_biomass=t(data.frame(BIO=BIO$BIO,B_STDEV=sqrt(VAR$BIO)))
BIO<-subset(BIO,YEAR!=2010)
Total_WB<-merge(Total_LB,BIO,all=T)
Total_WB$Prob<-Total_WB$FREQ/Total_WB$Total
Total_WB$C_LENGTH<-Total_WB$Prob*Total_WB$POP

CATCH_LENGTH<-aggregate(list(C_LENGTH=Total_WB$C_LENGTH),by=list(LENGTH=round(Total_WB$LENGTH,-1)YEAR=Total_WB$YEAR),FUN=sum)

## Output for Survey Catch at age
Total_test<-merge(Total_B,CATCH_LENGTH,all=T)
Total_test$CATCH_AGE<-Total_test$Prob*Total_test$C_LENGTH
Total<-subset(Total_test,is.na(Total_test$C_LENGTH)==F)
remove(Total_test)

FINAL_CATCH_AGE=aggregate(list(CATCH_AGE=Total$CATCH_AGE),by=list(AGE=Total$AGE,YEAR=Total$YEAR),FUN=sum)
FINAL_TOTAL<-aggregate(list(Total=FINAL_CATCH_AGE$CATCH_AGE),by=list(YEAR=FINAL_CATCH_AGE$YEAR),FUN=sum)

FINAL_CATCH_AGE=merge(FINAL_CATCH_AGE,FINAL_TOTAL)
FINAL_CATCH_AGE$PROP<-FINAL_CATCH_AGE$CATCH_AGE/FINAL_CATCH_AGE$Total

S_CATCH_PROP<-data.frame(matrix(ncol=15,nrow=length(unique(FINAL_CATCH_AGE$YEAR))))
names(S_CATCH_PROP)<-c("YEAR","A2","A3" ,"A4","A5","A6","A7","A8","A9","A10","A11","A12","A13","A14","A15")
Years1<-unique(AGE$YEAR)
S_CATCH_PROP$YEAR<-Years1

for( i in 1:length(Years1)){
S_CATCH_PROP[i,2:15]<-FINAL_CATCH_AGE$PROP[FINAL_CATCH_AGE$YEAR==Years1[i]][2:15]
}
S_CATCH_PROP[2,15]<-0
S_CATCH_PROP[3,15]<-0

##Survey Data
survey_biomass
S_CATCH_PROP
S_AGE_WEIGHT


#!/usr/bin/env Rscript

##################################################################################################################################################
############## CALCULATE AND PLOT EVOLUTION OF SPECIES POPULATION BY SPECIALIZATION GROUP  function:analyse.Groupe  ##############################
##################################################################################################################################################

#### Based on Romain Lorrillière R script
#### Modified by Alan Amosse and Benjamin Yguel for integrating within Galaxy-E

suppressMessages(library(lme4))
suppressMessages(library(ggplot2))
suppressMessages(library(speedglm))
suppressMessages(library(arm))
suppressMessages(library(ggplot2))
suppressMessages(library(reshape))
suppressMessages(library(data.table))
suppressMessages(library(reshape2))

source("FunctMainGlmGalaxy.r")### chargement des fonctions analyseGroupe, geometriqueWeighted et checkfile / load the functions analyseGroupe, geometriqueWeighted and checkfile

###########
#delcaration des arguments et variables/ declaring some variables and load arguments

args = commandArgs(trailingOnly=TRUE)

if (length(args)!=6) {
    stop("The tool need the following inputs :\n\n- A yearly species variations data set (.tabular). It may come from the main glm tool.\n- A species global tendencies dataset (.tabular). It may come from the main glm tool.\n- A species table filtered (.tabular). It may come from the Filter rare species tool.\n- An id to fix output repository name.\n- A list of species to exclude, can be empty.\n- A bias file.\n\n", call.=FALSE) #si pas d'arguments -> affiche erreur et quitte / if no args -> error and exit1
} else {
    donnees<-args[1] ###### Nom du fichier avec extension "***variationsAnnuellesEspece***.tabular", peut provenir de la fonction "mainglm" / file name without the file type "***variationsAnnuellesEspece***.tabular", may result from the function "mainglm"
    donneesTrend <- args[2] ####### Nom du fichier avec extension "***tendanceGlobalEspece***.tabular", peut provenir de la fonction "mainglm" / / file name without the file type "***tendanceGlobalEspece***.tabular", may result from the function "mainglm"
    tabSpecies<-args[3] ###### Nom du fichier avec extension ".typedefichier", peut provenir de la fonction "FiltreEspeceRare" / file name without the file type ".filetype", may result from the function "FiltreEspeceRare"
    id<-args[4]  ##### nom du dossier de sortie des resultats / name of the output folder
    spExclude <- args [5] ##### liste d'espece qu on veut exclure de l analyse  / list of species that will be excluded
    tBiais <-args [6] ##########   fichier contenant le biais de détéction en fonction des occurances, obtenu à partir d'un modéle théorique de dynamique de pop et de survey / the file containing the detection bias depending on occurance data obtained with theoretical model of population dynamic and survey
}

#Import des données / Import data
tBiais=read.table(tBiais,sep="\t",dec=".",header=TRUE) ###### charge le fichier contenant le biais de détéction en fonction des occurances, obtenu à partir d'un modéle théorique de dynamique de pop et de survey / load the file containing the detection bias obtained with theoretical model of population dynamic and survey
donnees <-  read.table(donnees,sep="\t",dec=".",header=TRUE) #### charge le fichier de resultat sur les tendances annuelles par espèce / load annual population evolution trend for each species obtained with the function mainglm
donneesTrend <- read.table(donneesTrend,sep="\t",dec=".",header=TRUE)#### charge le fichier de resultat sur les tendances sur la periode etudiée par espèce / load population evolution trend on the studied period for each species obtained with the function mainglm
tabsp <- read.table(tabSpecies,sep="\t",dec=".",header=TRUE)   #### charge le fichier de donnees sur nom latin, vernaculaire et abbreviation, espece indicatrice ou non / load the file with information on species specialization and if species are indicators

groupeNom = c("generaliste","milieux batis","milieux forestiers","milieux agricoles")
groupeCouleur = c("black","firebrick3","chartreuse4","orange")

vars_donnees<-c("id","code_espece","nom_espece","indicateur","annee","abondance_relative","IC_inferieur","IC_superieur","erreur_standard","p_value","significatif","nb_carre","nb_carre_presence","abondance")
err_msg_donnees<-"\nThe yearly species variation dataset doesn't have the right format. It need to have following 14 variables :\n- id\n- code_espece\n- nom_espece\n- indicateur\n- annee\n- abondance_relative\n- IC_inferieur\n- IC_superieur\n- erreur_standard\n- p_value\n- significatif\n- nb_carre\n- nb_carre_presence\n- abondance\n"

vars_donneesTrend<-c("id","code_espece","nom_espece","indicateur","nombre_annees","premiere_annee","derniere_annee","tendance","IC_inferieur","IC_superieur","pourcentage_variation","erreur_standard","p_value","significatif","categorie_tendance_EBCC","mediane_occurrence","valide","raison_incertitude")
err_msg_donneesTrend<-"\nThe species global tendances dataset doesn't have the right format. It need to have following 18 variables :\n- id\n- code_espece\n- nom_espece\n- indicateur\n- nombre_annees\n- premiere_annee\n- derniere_annee\n- tendance\n- IC_inferieur\n- IC_superieur\n- pourcentage_variation\n- erreur_standard\n- p_value\n- significatif\n- categorie_tendance_EBCC\n mediane_occurrence\n valide\n raison_incertitude\n"

vars_tabsp<-c("espece","nom","nomscientific","indicateur","specialisation")
err_msg_tabsp<-"\nThe species dataset filtered doesn't have the right format. It need to have the following 4 variables :\n- espece\n- nom\n- nomscientific\n- indicateur\n- specialisation\n"

vars_tBiais<-c("occurrenceMed","biais")
err_msg_tBiais<-"\nThe bias dataset doesn't have the right format. It need to have the following 2 variables :\n- occurenceMed\n- biais\n"

check_file(donnees,err_msg_donnees,vars_donnees,14)
check_file(donneesTrend,err_msg_donneesTrend,vars_donneesTrend,18)
check_file(tabsp,err_msg_tabsp,vars_tabsp,5)
check_file(tBiais,err_msg_tBiais,vars_tBiais,2)

spsFiltre=unique(levels(donnees$code_espece)) #### Recupère la liste des especes du tabCLEAN qui ont été sélectionnée et qui ont passé le filtre / retrieve species name that were selected and then filtered before

tabsp=subset (tabsp, (espece %in% spsFiltre)) #### Enlève les espèces qui n'ont pas passé le filtre ou exclu manuellement pour les analyses / keep only selected species and species with enough data
sp=as.character(tabsp$espece)  ##### liste des espece en code ou abbreviation gardées pour les analyses ### arg de la fonction  DECLARE AUSSI APRES DS FONCTION  / list of the code or abbreviation of the species kept for the analyses
tabsp=data.frame(tabsp,sp)### rajoute une colonne identique appelé sp / add new column called sp

cat("\n\nEspèces exclues de l'analyse :\n")
cat(spExclude)
cat("\n")
if(!is.null(spExclude)) {
    donnees <- subset(donnees,!(code_espece %in% spExclude))
    tabsp <- subset(tabsp, !(espece %in% spExclude))
}
## creation d'un dossier pour y mettre les resultats / create folder for the output of the analyses   ###### NORMALEMENT DOIT ËTRE DEJ2 CREER POUR LES SORTIES TENDANCES PAR SPS DONC PAS SUR QU IL FAUT REFAIRE CETTE ETAPE

dir.create(paste("Output/",id,sep=""),recursive=TRUE,showWarnings=FALSE)
cat(paste("Create Output/",id,"\n",sep=""))
dir.create(paste("Output/",id,"/Incertain/",sep=""),recursive=TRUE,showWarnings=FALSE)
cat(paste("Create Output/",id,"Incertain/\n",sep=""))

##################
###  Do your analysis
analyseGroupe(id,tabsp=tabsp,donnees=donnees,donneesTrend=donneesTrend,ICfigureGroupeSp=TRUE,groupeNom = groupeNom,groupeCouleur=groupeCouleur)


readMapDamData <- function(folder, termini="both", sub_length=12) {
    nucleotides <- c("A", "C", "G", "T")
    mismatches <- c("A.C", "A.G", "A.T",
                    "C.A", "C.G", "C.T",
                    "G.A", "G.C", "G.T",
                    "T.A", "T.C", "T.G")

    data <- read.table(paste(folder, "misincorporation.txt", sep=""), header=TRUE)
    data <- data[data$Pos <= sub_length, ]
    data[data$End == "3p", "Pos"] <- -data[data$End == "3p", "Pos"]

    if (termini == "5p" || termini == "3p") {
        data <- data[data$End == termini,]
    } else if (termini != "both") {
        abort("invalid termini '%s'", termini)
    }

    return(aggregate(
        data[, c(nucleotides, mismatches)],
        list(Pos=data[, "Pos"]),
        sum
    ))
}

readBaseFreqs <- function(folder) {
    # Get the nucleotide composition of the genome
    data <- read.csv(paste(folder, "dnacomp_genome.csv", sep=""), header=TRUE)

    return(c(data$A, data$C, data$G, data$T))
}


###VISUALISE MODEL OUTPUTS###
library(tidyverse)
library(ggpubr)

my_list = list(
  c("AFG", 0, -.3, 0, -.4, 1, -.3),
  c("AGO", 0, -.5, 0, -1.2, 1, -.6),
  c("BGD", 0, -.2, 0, -.5, 1, -.42),
  c("BTN", 1, -.3, 1, -.4, 2, -.3),
  c("CMR", 0, -.2, 0, -.5, 1, -.42),
  c("CRI", 1, -.3, 1, -.4, 2, -.3),
  c("EGY", 0, -.2, 0, -.7, 1, -.42),
  c("SLV", 1, -.3, 1, -.7, 1, -.4),
  c("GMB", 2, -.2, 2, -.5, 2, -.42),
  c("HND", 1, -.4, 1, -1.1, 2, -.7),
  c("IND", 0, -.2, 0, -2.2, 0, -2),
  c("KEN", 0, -.2, 0, -.6, 1, -.42),
  c("LKA", 0, -.3, 0, -.6, 1, -.3),
  c("MAR", 0, -.2, 0, -.7, 2, -.42),
  c("MDG", 0, -.2, 0, -.3, 1, -.42),
  c("MDV", 1, -1, 1, -1.3, 3, -.7),
  c("MOZ", 0, -.2, 0, -.5, 1, -.42),
  c("MWI", 0, -.2, 0, -1, 1, -.42),
  c("NPL", 0, -.2, 0, -.5, 1, -.42),
  c("NGA", 0, -.2, 0, -.5, 0, -.42),
  c("PAK", 0, -.2, 0, -1.2, 0, -1.4),
  c("SEN", 0, -.2, 0, -1, 1, -.3)
)

for(i in 1:length(my_list)) {
  print(i)
  iso3 = my_list[[i]][1]
  decimal_places_a = as.numeric(my_list[[i]][2])
  hjust_a = as.numeric(my_list[[i]][3])
  decimal_places_b = as.numeric(my_list[[i]][4])
  hjust_b = as.numeric(my_list[[i]][5])
  decimal_places_c = as.numeric(my_list[[i]][6])
  hjust_c = as.numeric(my_list[[i]][7])
  print(iso3)

  folder <- dirname(rstudioapi::getSourceEditorContext()$path)
  filename = paste(iso3,'.csv', sep="")
  path = file.path(folder, 'subscriptions', 'data_inputs', filename)

  data <- read.csv(path)

  data$scenario = factor(data$scenario, levels=c("low",
                                                 'baseline',
                                                 "high"
  ),
  labels=c("Low",
           "Baseline",
           "High"
  ))

  data = data[complete.cases(data),]

  subscriptions =
    ggplot(data, aes(x=year, y=penetration, group=scenario)) +
    geom_point(aes(shape=scenario, color=scenario), size=1) +
    geom_line(aes(color=scenario)) +
    scale_shape_manual(values=c(0, 1, 2, 3, 4, 5)) +
    scale_size_manual(values=c(0.1, 0.1, 0.1, 0.1, 0.1)) +
    scale_color_manual(values=c(
                                # "#F0E442",
                                #"#E69F00",
                                "#56B4E9",
                                "#009E73",
                                "#D55E00"#,
                                # "#0072B2"
                                )) +
    geom_vline(xintercept=2020, linetype="dashed", color = "grey", size=.5) +
    scale_x_continuous(expand = c(0, 0.5), limits = c(2010,2030),
                       breaks = seq(2010,2030,2)) +
    theme(axis.text.x = element_text(angle = 45, hjust = 1),
          legend.position = "bottom", legend.title=element_blank()) +
    labs(title = "(A) Mobile Subscription Forecast by Scenario",
         x = NULL, y = "Subscribers (%)") +
    guides(shape=guide_legend(ncol=6), colour=guide_legend(ncol=6))

  #get folder directory
  folder <- dirname(rstudioapi::getSourceEditorContext()$path)
  filename = paste(iso3,'.csv', sep="")
  path = file.path(folder, 'smartphones', 'data_inputs', filename)

  data <- read.csv(path)

  data$scenario = factor(data$scenario, levels=c("low",
                                                 'baseline',
                                                 "high"
  ),
  labels=c("Low",
           "Baseline",
           "High"
  ))

  data$settlement_type = factor(data$settlement_type,
                                levels=c("urban",
                                         "rural"),
                                labels=c("Urban",
                                         "Rural"))

  data = data[complete.cases(data),]
  data$country = NULL

  smartphones =
    ggplot(data, aes(x=year, y=penetration, group=scenario)) +
    geom_point(aes(shape=scenario, color=scenario), size=1) +
    geom_line(aes(color=scenario)) +
    scale_shape_manual(values=c(0, 1, 2, 3, 4, 5)) +
    scale_color_manual(values=c("#009E73", "#F0E442","#E69F00"#,
                                #"#56B4E9","#D55E00", "#0072B2"
                                )) +
    scale_x_continuous(expand = c(0, 0.25), limits = c(2020,2030),
                       breaks = seq(2020,2030,2)) +
    scale_y_continuous(expand = c(0, 0), limits = c(0,100)) +
    theme(axis.text.x = element_text(angle = 45, hjust = 1),
          legend.position = "bottom", legend.title=element_blank()) +
    labs(title = "(B) Smartphone Penetration Forecast by Scenario",
         x = NULL, y = "Smartphones (%)") +
    guides(shape=guide_legend(ncol=6), colour=guide_legend(ncol=6)) +
    facet_grid(~settlement_type)

  combined <- ggarrange(subscriptions, smartphones,
                        ncol = 1, nrow = 2,
                        common.legend = TRUE,
                        legend='bottom', heights=c(5, 5))

  path = file.path(folder, 'figures', iso3, 'demand_graphic.png')
  ggsave(path, units="in", width=6, height=5.5, dpi=300)
  print(combined)
  dev.off()

  dir.create(file.path(folder, '..', 'reports', 'images', iso3), showWarnings = FALSE)
  path = file.path(folder, '..', 'reports', 'images', iso3, 'demand_graphic.png')
  ggsave(path, plot = last_plot(), units="in", width=8, height=7, dpi=300)

  remove(subscriptions, smartphones, combined, data)
}


#CSA = Cluster Soccer Analysis
rm(list = ls())
cat("\014")

path <- dirname(parent.frame(2)$ofile)
setwd(path)

#call the utility.r file for usefull environment and dataset functions
source("utility.R")

environmentSettings()

FinalDatasetLight <- loadDataset(path, "FinalDatasetLight.csv")

FinalDatasetLight <- trasformDataset(FinalDatasetLight)

description <- datasetDescription(FinalDatasetLight)
print(description)

#Get the top 20 players
top20 <-
  FinalDatasetLight %>%
  arrange(desc(overall)) %>%
  head(n = 20) %>%
  as.data.frame()

#Display the players tabel for export
top20 %>%
  select(player_name, height, weight, overall, potential, strong_foot,interceptions,gk_diving,finishing) %>%
  datatable(., options = list(pageLength = 10),caption=(h1="Best Players")) -> datatableTop20
DT::saveWidget(datatableTop20,file="dataTable.html")
print(top20)

#Overall score charts
Desc(FinalDatasetLight$overall, plotit = TRUE) %>% print()
Desc(top20$overall, plotit = TRUE) %>% print()

#Print Interactive correlation map
top20 %>% select(-strong_foot,-player_name,-birthday, -work_rate_att, -work_rate_def) -> top20NumericVariables
iplotCorr(top20NumericVariables, reorder=TRUE, rows=TRUE, cols=TRUE,scatterplot=TRUE) -> plotCorr
htmlwidgets::saveWidget(plotCorr,file="corrMatrix.html")
print(plotCorr)

#Print relationship between overall and other numeric measurement
#Use shiny for the graphics
#get all the measure data labels
measures <- top20NumericVariables %>%
  select(-overall) %>%
  names()

#Create the radarchart to see a complete profile of a single player
#Data first had to be transformed to work with the radarchart package.
radarDF <- top20 %>%
  select(-id, -overall, -height, -weight,
         -potential,-quote) %>% as.data.frame()

radarDF <- gather(radarDF, key=Label, value=Score, -player_name) %>%
  spread(key=player_name, value=Score)

chartJSRadar(scores = radarDF, showToolTipLabel = TRUE, showLegend = TRUE, responsive=TRUE) -> radarPlot
htmlwidgets::saveWidget(radarPlot,file="radarPlot.html")
print(radarPlot)

#print the releationship plot

top20 %>%
  ggvis(x = input_select(measures, label = "Choose the x-axis:", map = as.name)) %>%
  layer_points(y = ~overall, fill = ~player_name)  -> dynamicViz

#ATTENTION!!! PRESS ESCAPE TO EXIT THE DYNAMIC PLOT!!


updateScores = function(templateResponse, currentItems, currentItemsIndices, scores) {
  for(i in 1:dim(currentItems)[1]) {
    item = currentItems[i,]
    index = currentItemsIndices[i]
    itemResponse = templateResponse[[paste0("r",item$id)]]
    responseOptions = fromJSON(item$responseOptions)
    score = responseOptions$defaultScore

    if(!is.null(itemResponse)) {
      if(length(responseOptions$scoreMap) > 0) {
        for(i in 1:length(responseOptions$scoreMap)) {
          sm = responseOptions$scoreMap[[i]]
          if(sm$value == itemResponse) {
            score = sm$score
            break
          }
        }
      }
    }

    scores[index] = as.numeric(score)
  }
  return(scores)
}

updateTraitScores = function(scores, items) {
  traitScores = list()
  for(i in 1:length(scores)) {
    score = as.numeric(scores[[i]])
    if(is.null(score)) { score = 0 }
    item = as.list(items[i,])
    if(is.null(traitScores[[item$trait]])) {
      traitScores[[item$trait]] = 0
    }
    traitScores[[item$trait]] = traitScores[[item$trait]] + score
  }
  return(traitScores)
}

scores = updateScores(response, currentItems, currentItemsIndices, scores)
traitScores = updateTraitScores(scores, items)

concerto.log(scores, "scores")
concerto.log(traitScores, "traitScores")