Rebol [
	title: "SWF Examiner"
	Author: "oldes"
	Date:   17-12-2001
	version: 0.0.12
    File:    %exam-swf.r
    Email:   oliva.david@seznam.cz
	Purpose: {
       Basic SWF  parser which can
	   show all standard informations from the file.
    }
    Category: [file util 3]
	History: [
		0.0.12 [17-12-2001 {Support for new tags} "oldes"]
		0.0.7 [30-11-2001 {
		Fixed converting numbers from binary.
		Added support for some other tags as morping and so on} "oldes"]
		0.0.2 [6-11-2001 "New start..." "oldes"]
		0.0.1 [3-Sep-2000 "Initial version" "oldes"]
	]
	comment: {}
]

details?: true
system/options/binary-base: 16

;--------------------------------------

swf-tags: [
	0 ["end" [print ""]]
	1 ["showFrame" [print ""]]
	2 ["DefineShape" [either details? [parse-DefineShape][probe tag-bin]]]
	4 ["PlaceObject2" [parse-PlaceObject]]
	22 ["DefineShape2" [either details? [parse-DefineShape][probe tag-bin]]] ;Extends the capabilities of DefineShape with the ability to support more than 255 styles in the style list and multiple style lists in a single shape. (SWF 2.0)
	24 ["Protected file!"]
	32 ["DefineShape3" [either details? [parse-DefineShape][probe tag-bin]]]	;Extends the capabilities of DefineShape2 by extending all of the RGB color fields to support RGBA with alpha transparency. (SWF 3.0)
	9 ["setBackgroundColor" [print to-tuple tag-bin]]
	10 ["DefineFont" [parse-defineFont]]
	11 ["DefineText" [parse-defineText]]
	13 ["DefineFontInfo" [parse-DefineFontInfo]]
	12 ["DoAction Tag" [print "" parse-ActionRecord tag-bin]]
	20 ["DefineBitsLossless" [parse-DefineBitsLossless]]
	21 ["DefineBitsJPEG2" [parse-DefineBitsJPEG2]]
	26 ["PlaceObject2" [parse-PlaceObject2]]
	28 ["RemoveObject2" ]
	34 ["DefineButton2" [parse-DefineButton2]]
	36 ["DefineBitsLossless2" [parse-DefineBitsLossless]]
	37 ["DefineEditText" [parse-DefineEditText]]
	39 ["DefineSprite" [parse-sprite]]
	40 ["SWT-CharacterName" [
		print ["ID:" tag-bin-part/rev 2 "="	mold to-string copy/part tag-bin find tag-bin #{00}]
	]]
	43 ["FrameLabel" [print mold to-string head remove back tail tag-bin]]
	46 ["DefineMorphShape" [parse-DefineMorphShape]]
	48 ["DefineFont2" [parse-DefineFont2]]
	;swf 5
	56 ["ExportAssets" [parse-Assets]]
	57 ["ImportAssets" [parse-Assets/import]]
	58 ["EnableDebugger" [prin "Password:" probe tag-bin]]
	;swf6
	59 ["DoInitAction" [print "" parse-ActionRecord/init tag-bin]]
	62 ["DefineFontInfo2" [parse-DefineFontInfo/mx]]
]

;help functions:
getpart: func[bytes /rev /local tmp][
	tmp: copy/part swf-bin bytes
	swf-bin: skip swf-bin bytes
	either rev [reverse tmp][tmp]
]

round: func[val digits /local i d][
	either parse mold val [copy i to "." 1 skip copy d to end][
		load rejoin [i #"." copy/part d digits]
	][ val ]
]

slice-bin: func [
	"Slices the binary data to parts which length is specified in the bytes block"
	bin [string! binary!]
	bytes [block!]
	/integers "Returns data as block of integers"
	/local tmp b
][
	tmp: make block! length? bytes
	forall bytes [
		b: copy/part bin bytes/1
		append tmp either integers [to-integer debase/base refill-bits b 2][b]
		bin: skip bin bytes/1
	]
	tmp
]
extract-data: func[type][
	swf/chunk/data: slice-bin/integers swf/chunk/data select swf/chunk-bytes type
]

extend-int: func[num /local i][
	i: num // 8
	if i > 0 [num: num + 8 - i]
	num
]

refill-bits: func[
	"When an unsigned bit value is expanded into a larger word size the leftmost bits are filled with zeros."
	bits
	/local n
][
	bits
	n: (length? bits) // 8
	if n > 0 [
		n: 8 - n
		insert/dup head bits #"0" n
	]
	bits
]
;end of help functions

bin-to-decimal: func [
    {convert a binary native into a decimal value - also accepts a binary
    string representation in the format returned by REAL/SHOW}
    in      [binary!]
    /local sign exponent fraction
][
    in: copy in
    insert tail in copy/part in 4
	in: reverse remove/part in 4

    sign: either zero? to integer! (first in) / 128 [1][-1]
    exponent: (first in) // 128 * 16 + to integer! (second in) / 16
    fraction: to decimal! (second in) // 16
    in: skip in 2
    loop 6 [
        fraction: fraction * 256 + first in
        in: next in
    ]
    sign * either zero? exponent [
        2 ** -1074 * fraction
    ][
        2 ** (exponent - 1023) * (2 ** -52 * fraction + 1)
    ]
]

UB-to-int: func[
	"converts unsigned bits to integer"
	bits [string! none!]
][
	if none? bits [return 0]
	to-integer debase/base refill-bits bits 2
]
SB-to-int: func[
	"converts signed bits to integer"
	bits [string! binary!]
][
	if binary? bits [bits: enbase/base reverse bits 2]
	to-integer debase/base head insert/dup bits bits/1 (32 - length? bits) 2
]
FB-to-int: func [
	"converts signed fixed-point bit value to integer"
	bits [string!]
	/local s p x y
][
	s: either bits/1 = #"1" [-1][1]
	bits: copy next bits
	p: (length? bits) - 16
	parse bits [copy x p skip copy y to end]
	if none? x [x: ""]
	if none? y [y: "0"]
	d: to-integer (UB-to-int y) / .65535
	i: load rejoin [UB-to-int x "." d]
	if s = -1 [
		i: -1 * either (i // 1) = 0 [i][((to-integer i) + (1 - (i // 1)))]
	]
	i
]
bin-to-int: func[bin][to-integer reverse bin]
str-to-int: func[str][bin-to-int to-binary str]
get-rect: func[
	"Parses Rectangle Record => returns block: [xmin xmax ymin ymax]"
	bin [string! binary!]
	/integers "returns values converted to integers"
	/local nbits rect
][
	nbits: to-integer debase/base (refill-bits copy/part bin 5) 2
	skip-val: 5 + (4 * nbits)
	rect: slice-bin (skip bin 5) reduce [nbits nbits nbits nbits]
	if integers [forall rect [rect/1: SB-to-int rect/1] rect: head rect]
	rect
]

tabs: has [t][t: make string! indent insert/dup t tab indent t]
ind-: does [indent: indent - 1]
ind+: does [indent: indent + 1]

tag-bin-part: func[bytes /rev /twips "Converts the result to number in twips" /local tmp][
	tmp: copy/part tag-bin bytes
	tag-bin: copy skip tag-bin bytes
	either rev [
		reverse tmp
	][	either twips [(to-integer reverse tmp) / 20][tmp]]
]

get-count: func["Gets the count value from tag-bin (used in some tags)" /local c][
	c: tag-bin-part 1
	to-integer either c = #{FF} [tag-bin-part/rev 2][c]
]

parse-Assets: func[ /import /local assets file id name][
	assets: make block! 6
	either import [
		parse/all tag-bin [
			copy file to #"^@" 3 skip
			some [
				copy id 2 skip copy name to #"^@" 1 skip
				(append assets reduce [bin-to-int to-binary id name])
			]
		]
		assets: reduce [file assets]
	][
		parse/all tag-bin [
			2 skip
			some [
				copy id 2 skip copy name to #"^@" 1 skip
				(append assets reduce [bin-to-int to-binary id name])
			]
		]
	]
	probe assets
]
parse-DefineBitsJPEG2: func[][
	ind+
	print ""
	print [tabs "Bitmap ID:" tag-bin-part/rev 2]
	write/binary %/e/jpg.test tag-bin
	ind-
]
parse-DefineBitsLossless: func[][
	ind+
	print ""
	;probe tag-bin
	print [tabs "Bitmap ID:" tag-bin-part/rev 2]
	print [tabs "BitmapFormat:" select [3 8 4 16 5 32] to-integer tag-bin-part 1 "bits"]
	print [tabs "Size:" to-pair reduce [
		to-integer tag-bin-part/rev 2
		to-integer tag-bin-part/rev 2]
	]
	print [tabs "BitmapColorTableSize:" tag-bin-part 1]
	;probe ( zlib/decompress tag-bin)
	ind-
]

parse-DefineMorphShape: func[/local i end-bin][
	ind+
	print "" ;tag-bin
	print [tabs "Char ID:" tag-bin-part/rev 2]
	print [tabs "Rect start:" mold get-rect/integers enbase/base tag-bin 2]
	tag-bin: skip tag-bin (extend-int skip-val) / 8
	print [tabs "Rect end  :" mold get-rect/integers enbase/base tag-bin 2]
	tag-bin: skip tag-bin (extend-int skip-val) / 8
	print [tabs "Offset:" i: to-integer tag-bin-part/rev 4]
	end-bin: copy skip tag-bin i
	print [tabs "MorphFillStyles:" i: get-count]
	loop i [parse-MORPHFILLSTYLE]
	print [tabs "MorphLineStyles:" i: get-count]
	ind+
	loop i [
		print [tabs "StartWidth:" to-integer tag-bin-part/rev 2]
		print [tabs "EndWidth  :" to-integer tag-bin-part/rev 2]
		print [tabs "StartColor:" to-tuple tag-bin-part 4]
		print [tabs "EndColor  :" to-tuple tag-bin-part 4]
	]
	ind-
	print [tabs "StartEdges:"]
	ind+ parse-SHAPE ind-
	print [tabs "EndEdges:"]
	tag-bin: end-bin
	ind+ parse-SHAPE ind-
	ind-
]

parse-MORPHFILLSTYLE: func[/local type i][
	ind+
	print [tabs "Type:" type: tag-bin-part 1]
	if type = #{00} [
		print [tabs "StartColor:" to-tuple tag-bin-part 4]
		print [tabs "EndColor  :" to-tuple tag-bin-part 4]
	]
	if type = #{10} [
		print [tabs "StartGradientMatrix:" parse-matrix]
		print [tabs "EndGradientMatrix  :" parse-matrix]
		print [tabs "Gradients:" i: tag-bin-part 1]
		ind+
		loop i [
			print [tabs "StartRatio:" tag-bin-part 1]
			print [tabs "StartColor:" to-tuple tag-bin-part 4]
			print [tabs "EndRatio  :" tag-bin-part 1]
			print [tabs "EndColor  :" to-tuple tag-bin-part 4]
		]
		ind-
	]
	if find #{4041} type [
		print [tabs "BitmapId:" tag-bin-part/rev 2]
		print [tabs "StartBitmapMatrix:" parse-matrix]
		print [tabs "EndBitmapMatrix  :" parse-matrix]
	]
	ind-
]
parse-DefineButton2: func[/local tmp ofs key menu?][
	ind+
	print "" ;tag-bin
	print [tabs "Button ID:" tag-bin-part/rev 2]
	print [tabs "Menu:" menu?: #{01} = tag-bin-part 1]
	;Offset to the first Button2ActionCondition
	ofs: to-integer tag-bin-part/rev 2
	;print [tabs "Offset:" ofs]
	ofs: either ofs = 0 [(length? tag-bin) - 1][ofs - 3]
	parse-BUTTONRECORD tag-bin-part ofs
	tag-bin-part 1 ;ButtonEndFlag = #{00}
	if not empty? tag-bin [
		print [tabs "Actions:"]
		ind+
		while [not tail? tag-bin][
			ofs: to-integer tag-bin-part/rev 2
			;print [tabs "ActionsOffset:" ofs]
			parse (enbase/base tag-bin-part/rev 2 2) [
				copy key 7 skip copy tmp to end
			]
			st: make block! []
			either menu? [
				if tmp/1 = #"1" [insert st 'DragOut]
				if tmp/2 = #"1" [insert st 'DragOver]
			][
				if tmp/3 = #"1" [insert st 'ReleaseOutside]
				if tmp/4 = #"1" [insert st 'DragOver]
			]
			if tmp/5 = #"1" [insert st 'DragOut]
			if tmp/6 = #"1" [insert st 'Release]
			if tmp/7 = #"1" [insert st 'Press]
			if tmp/8 = #"1" [insert st 'RollOut]
			if tmp/9 = #"1" [insert st 'RollOver]
			print [tabs "Condition:" mold st "Key:" mold to-char ub-to-int key]
			tmp: tag-bin-part either ofs = 0 [length? tag-bin][ofs - 4]
			;first 7bits are reserved
			parse-ActionRecord tmp
		]
		ind-
	]
	ind-
]

parse-BUTTONRECORD: func[bin /local buff tmp st][
	buff: copy tag-bin tag-bin: copy bin
	print [tabs "Buttons:" tag-bin ]
	ind+
		while [not tail? tag-bin][
		tmp: copy skip (enbase/base tag-bin-part 1 2) 4
		st: make block! 4
		repeat i 4 [
			if tmp/:i = #"1" [insert st pick [hit down over up] i]
		]
		print [tabs "States:" mold st]
		ind+
		print [tabs "ButtonCharacter:" tag-bin-part/rev 2]
		print [tabs "ButtonLayer:" tag-bin-part/rev 2]
		ind-
		parse-matrix
		parse-CXFORMWITHALPHA
		]
	ind-
	tag-bin: buff
]

parse-DefineFontInfo: func[/mx /local nameLen flags CodeTable][
	ind+
	print ""
	print [tabs "Font ID:" tag-bin-part 2]
	NameLen: to-integer tag-bin-part 1
	print [tabs "Name:" to-string tag-bin-part NameLen]
	print [tabs "Flags:" flags: enbase/base tag-bin-part 1 2]
	if mx [
		print [tabs "LanguageCode:"  to-integer tag-bin-part 1]
	]
	CodeTable: tag-bin
	print [tabs "Glyphs in CodeTable:" (length? CodeTable) / 2]
	ind-
]

parse-DefineFont2: func[/local flags NameLen glyphs ofsTable wideOfs ofsFST
	FontShapeTable
][
	ind+
	print ""
	;print tag-bin
	print [tabs "Font ID:" tag-bin-part/rev 2]
	flags: enbase/base tag-bin-part 2 2
	print [tabs "Flags:" flags]
	NameLen: to-integer tag-bin-part 1
	print [tabs "Name:" to-string tag-bin-part NameLen]
	print [tabs "Glyphs:" glyphs: to-integer tag-bin-part/rev 2]
	wideOfs: either flags/5 = #"1" [4][2]
	print [tabs "OffsetTable:" ofsTable: tag-bin-part (glyphs * wideOfs)]
	print [tabs "CodeOffset:" codeOffset: to-integer tag-bin-part/rev wideOfs]
	ofsFST: codeOffset - (length? ofsTable) - wideOfs
	;parse-SHAPE
	FontShapeTable: tag-bin-part ofsFST
	print [tabs "FontShapeTable:" length? FontShapeTable]
	FontCodeTable: tag-bin-part (glyphs * (wideOfs / 2))
	print [tabs "FontCodeTable:" length? FontCodeTable]
	if flags/1 = #"1" [
		print [tabs "FontAscent:" SB-to-int tag-bin-part 2]
		print [tabs "FontDescent:" SB-to-int tag-bin-part 2]
		print [tabs "FontLeading:" SB-to-int tag-bin-part 2]
		FontAdvanceTable: tag-bin-part glyphs * 2
		;FontBoundsTable: tag-bin-part glyphs *
	]
	if not empty? tag-bin [
		print [tabs "..." tag-bin]
	]
	ind-
]

parse-defineFont: func[][
	ind+
	print ""
	print [tabs "Font ID:" tag-bin-part 2]
	print [tabs "...:" tag-bin]
	ind-
]
parse-defineText: func[/local flags][
	ind+
	print ""
	print [tabs "Text ID:" tag-bin-part/rev 2]
	print [tabs "Rect:" mold get-rect/integers enbase/base tag-bin 2]
	tag-bin: skip tag-bin (extend-int skip-val) / 8
	print [tabs "Matrix:" tag-bin] parse-matrix
	print [tabs "NglyphBits:" NglyphBits: to-integer tag-bin-part 1]
	print [tabs "NadvanceBits:" NadvanceBits: to-integer tag-bin-part 1]
	print [tabs "TextRecords:" tag-bin]
	ind+
	while [#{00} <> flags: tag-bin-part 1][
		flags: enbase/base flags 2
		either flags/1 = #"1" [
			;Text Style Change Record
			if flags/5 = #"1" [
				print [tabs "TextFontID:" tag-bin-part/rev 2 ]
			]
			if flags/6 = #"1" [
				print [tabs "TextColor:" to-tuple tag-bin-part either tagid = 11 [3][4]]
			]
			if flags/7 = #"1" [
				print [tabs "TextXOffset:" to-integer tag-bin-part/rev 2 ]
			]
			if flags/8 = #"1" [
				print [tabs "TextYOffset:" to-integer tag-bin-part/rev 2 ]
			]
			if flags/5 = #"1" [
				print [tabs "TextHeight:" (to-integer tag-bin-part/rev 2) / 20 ]
			]
		][
			;Glyph Record
			print [tabs "TextGlyphCount:" nGlyphs: ub-to-int copy next flags]
			probe bytes: (extend-int (nGlyphs * (NglyphBits + NadvanceBits))) / 8
			probe bits: enbase/base tag-bin-part bytes 2
			parse bits [any [
				copy i NglyphBits skip
				copy j NadvanceBits skip
				(print [tabs "GlyphEntry:" ub-to-int i sb-to-int j])
			]]
		]
	]
	ind-
	ind-
]
parse-DefineEditText: func[/local flags bits rect InitialText var][
	ind+
	print ""
	probe tag-bin
	print [tabs "TextID:" tag-bin-part/rev 2]
	bits: enbase/base tag-bin 2
	rect: get-rect bits
	bits: skip bits extend-int (5 + (4 * length? rect/1))
	forall rect [rect/1: SB-to-int rect/1] rect: head rect
	print [tabs "Bounds:" rect]
	flags: copy/part bits 16
	tag-bin: load rejoin ["2#{" skip bits 16 "}"]
	print [tabs "Flags:" flags]
	ind+
	if flags/8 = #"1" [
		print [tabs "HasFont:" tag-bin-part/rev 2]
		print [tabs "FontHeight:" tag-bin-part/twips 2]
	]
	if flags/6 = #"1" [print [tabs "TextColor:" tag-bin-part 4]]
	if flags/7 = #"1" [print [tabs "MaxLength:" to-integer tag-bin-part/rev 2]]
	if flags/11 = #"1" [
		;HasLayout
		print [tabs "Align:" pick ['left 'right 'center 'justify] 1 + to-integer tag-bin-part 1]
		print [tabs "LeftMargin:" tag-bin-part/twips 2]
		print [tabs "RightMargin:" tag-bin-part/twips 2]
		print [tabs "Indent:" tag-bin-part/twips 2]
		print [tabs "Leading:" tag-bin-part/twips 2]
	]
	ind-
	parse/all tag-bin [copy var to #"^@" 1 skip InitialText: [to #"^@" | to end]]
	print [tabs "VariableName:" var]
	if flags/1 = #"1" [print [tabs "InitialText:" InitialText]]

	probe debase/base bits 2

	ind-
]
parse-PlaceObject: func[/local flags depth CharacterID][
	ind+
	print tag-bin
	print [tabs "CharID:" tag-bin-part 2]
	print [tabs "Depth:" tag-bin-part 2]
	parse-matrix

	ind-
]
parse-PlaceObject2: func[/local flags depth CharacterID r MXflags][
	ind+
	print "";tag-bin
	set [flags depth] slice-bin tag-bin-part 3 [1 2]
	flags: enbase/base flags 2
	print [tabs "Flags:" flags]
	print [tabs "Depth:" to-integer reverse depth]
	print [tabs  either flags/8 = #"1" ["Character is already in the list"]["Placing new character"]]
	if flags/7 = #"1" [
		print [tabs "CharacterID:" to-integer tag-bin-part/rev 2]
	]
	if flags/6 = #"1" [
		print [tabs "Matrix:" ]
		parse-matrix
	]
	if flags/5 = #"1" [
		print [tabs "ColorTransform:" tag-bin]
		parse-CXFORM
	]
	if flags/4 = #"1" [
		print [tabs "Ratio:" r: to-integer tag-bin-part/rev 2 rejoin ["( " round (r / 65535 * 100) 2 "% )"]]
	]
	if flags/2 = #"1" [
		print [tabs "ClipDepth:" to-integer tag-bin-part/rev 2]
	]
	if flags/3 = #"1" [
		print [tabs "Name:" mold to-string tmp: copy/part tag-bin find tag-bin #{00}]
		tag-bin: skip tag-bin 1 + length? tmp
	]
	if flags/1 = #"1" [
		print [tabs "ClipActions:" tag-bin]
		something: tag-bin-part 2
		print [tabs "Flags:" flags: enbase/base tag-bin-part 2 2]
		either swf/header/version > 5 [
			something: tag-bin-part 2
			while [#{00000000} <> type: tag-bin-part 4][
				print [tabs "On" select [
					#{01000000} "Load"
					#{02000000} "EnterFrame"
					#{04000000} "Unload"
					#{10000000} "MouseDown"
					#{20000000} "MouseUp"
					#{08000000} "MouseMove"
					#{40000000} "KeyDown"
					#{80000000} "KeyUp"
					#{00010000} "Data"
					] type
				]
				ofs: to-integer tag-bin-part/rev 4
				parse-ActionRecord tag-bin-part ofs
			]
		][
			while [#{0000} <> type: tag-bin-part 2][
				print [tabs "On" select [
					#{0100} "Load"
					#{0200} "EnterFrame"
					#{0400} "Unload"
					#{1000} "MouseDown"
					#{2000} "MouseUp"
					#{0800} "MouseMove"
					#{4000} "KeyDown"
					#{8000} "KeyUp"
					#{0001} "Data"
					] type
				]
				ofs: to-integer tag-bin-part/rev 4
				parse-ActionRecord tag-bin-part ofs
			]
		]
	]
	ind-
]

parse-CXFORM: func[/local bits flags nBits v1 v2 v3][
	ind+
	bits: enbase/base copy tag-bin 2
	flags: copy/part bits 2
	bits: skip bits 2
	nBits: UB-to-int copy/part bits 4
	bits: skip bits 4
	used-bits: 6
	if flags/2 = #"1" [
		parse bits [copy v1 nBits skip copy v2 nBits skip copy v3 nBits skip copy bits to end]
		print [tabs "Multiply:" SB-to-int v1 SB-to-int v2 SB-to-int v3]
		used-bits: used-bits + (3 * nBits)
	]
	if flags/1 = #"1" [
		parse bits [copy v1 nBits skip copy v2 nBits skip copy v3 nBits skip copy bits to end]
		print [tabs "Addition:" SB-to-int v1 SB-to-int v2 SB-to-int v3]
		used-bits: used-bits + (3 * nBits)
	]
	tag-bin: skip tag-bin (extend-int used-bits) / 8
	ind-
]
parse-CXFORMWITHALPHA: func[/local bits flags nBits v1 v2 v3 v4][
	ind+
	bits: enbase/base copy tag-bin 2
	flags: copy/part bits 2
	bits: skip bits 2
	nBits: UB-to-int copy/part bits 4
	bits: skip bits 4
	used-bits: 6
	if flags/2 = #"1" [
		parse bits [copy v1 nBits skip copy v2 nBits skip copy v3 nBits skip copy v4 nBits skip copy bits to end]
		print [tabs "Multiply:" SB-to-int v1 SB-to-int v2 SB-to-int v3 SB-to-int v4]
		used-bits: used-bits + (4 * nBits)
	]
	if flags/1 = #"1" [
		parse bits [copy v1 nBits skip copy v2 nBits skip copy v3 nBits skip copy v4 nBits skip copy bits to end]
		print [tabs "Addition:" SB-to-int v1 SB-to-int v2 SB-to-int v3 Sb-to-int v4]
		used-bits: used-bits + (4 * nBits)
	]
	tag-bin: skip tag-bin (extend-int used-bits) / 8
	ind-
]
parse-matrix: func[
	/local bits used-bits val
	 ScaleX ScaleY RotateSkew0 RotateSkew1 TranslateX TranslateY
][
	ind+
	bits: enbase/base copy tag-bin 2
	used-bits: 7
	parse bits [
		[
			#"0" ;(tabs print "Has no scale")
			|
			#"1" (prin [tabs "Scale:"])
			copy val 5 skip (val: UB-to-int val)
			copy ScaleX val skip
			copy ScaleY val skip
			(print [(FB-to-int ScaleX) "x" (FB-to-int ScaleY)]
				used-bits: used-bits + 5 + (2 * val)
			)
		]
		[
			#"0" ;(print "Has no rotation")
			|
			#"1" (prin [tabs "Rotation: "])
			copy val 5 skip (val: UB-to-int val)
			copy RotateSkew0 val skip
			copy RotateSkew1 val skip
			(	print [FB-to-int RotateSkew0 FB-to-int RotateSkew1]
				used-bits: used-bits + 5 + (2 * val)
			)
		]
		copy val 5 skip (val: UB-to-int val)
		copy TranslateX val skip
		copy TranslateY val skip
		(
			if val = 0 [TranslateX: TranslateY: "0"]
			print [tabs "Translate:" (SB-to-int TranslateX) / 20 (SB-to-int TranslateY) / 20]
			used-bits: used-bits + (2 * val)
		)
		to end
	]
	tag-bin: skip tag-bin (extend-int used-bits) / 8
	ind-
]

parse-sprite: func[][
	ind+
	print ""
	;print tag-bin
	print [tabs "Sprite ID:" tag-bin-part 2]
	print [tabs "FrameCount:" tag-bin-part 2]
		ind+
		probe tag-bin
		foreach-tag tag-bin  show-info
		ind-
	ind-
]
parse-DefineShape: func [][
	ind+
	print "";tag-bin
	print [tabs "ShapeId:" tag-bin-part 2]
	print [tabs "Rect:" mold get-rect/integers enbase/base tag-bin 2]
	tag-bin: skip tag-bin (extend-int skip-val) / 8
	parse-SHAPE/WITHSTYLE
	ind-
]

parse-SHAPE: func[/withstyle /local fills bits NumBits points b][
	if withstyle [
		parse-FILLSTYLEARRAY
		parse-LINESTYLEARRAY
	]
	NumBits: slice-bin/integers (enbase/base tag-bin-part 1 2) [4 4]
	print [tabs "NumFillBits:" NumBits/1]
	print [tabs "NumLineBits:" NumBits/2]
	bits: enbase/base copy tag-bin 2

	d-pos: 0x0	;drawing position
	points: make block! []
	add-point: func[x y][
		np: to-pair reduce [
			d-pos/1 + x
			d-pos/2 + y
		]
		append points np
		d-pos: np
	]
	while ["000000" <> copy/part bits 6 ][
		either bits/1 = #"0" [
			;STYLECHANGERECORD
			states: next copy/part bits 6
			bits: skip bits 6
			print [tabs "States:" states]
			if states/5 = #"1" [
				;Move bit count
				MoveBits: UB-to-int copy/part bits 5
				bits: skip bits 5
				;print [tabs "MoveBits:" MoveBits]
				MoveDeltaX: SB-to-int copy/part bits MoveBits
				bits: skip bits MoveBits
				MoveDeltaY: SB-to-int copy/part bits MoveBits
				print [tabs "MoveX:" MoveDeltaX / 20]
				print [tabs "MoveY:" MoveDeltaY / 20]
				bits: skip bits MoveBits
				insert points d-pos: to-pair reduce [MoveDeltaX MoveDeltaY]
			]
			if states/4 = #"1" [
				;Fill style 0 change flag
				FillStyle0: UB-to-int copy/part bits NumBits/1
				bits: skip bits NumBits/1
				print [tabs "FillStyle0:" FillStyle0]
			]
			if states/3 = #"1" [
				;Fill style 1 change flag
				FillStyle1: UB-to-int copy/part bits NumBits/1
				bits: skip bits NumBits/1
				print [tabs "FillStyle1:" FillStyle1]
			]
			if states/2 = #"1" [
				;Line style change flag
				LineStyle: UB-to-int copy/part bits NumBits/2
				bits: skip bits NumBits/2
				print [tabs "LineStyle:" LineStyle]
			]
			if states/1 = #"1" [
				;New styles flag
				print "NEW STYLES"
				b: length? bits
				bits: refill-bits copy bits
				b: (length? bits) - b
				tag-bin: debase/base bits 2
				if b > 0 [tag-bin-part 1]
				parse-FILLSTYLEARRAY
				parse-LINESTYLEARRAY
				NumBits: slice-bin/integers (enbase/base tag-bin-part 1 2) [4 4]
				print [tabs "NumFillBits:" NumBits/1]
				print [tabs "NumLineBits:" NumBits/2]
				bits: enbase/base copy tag-bin 2
			]
		][
			;Edge Records
			bits: next bits
			Straight?: bits/1 = #"1"
			bits: next bits
			ind+
			NBits: 2 + UB-to-int copy/part bits 4
			bits: skip bits 4
			;print [tabs "NBits:" NBits]

			either Straight? [
				;StraightFlag
				print [tabs "StraightFlag"]
				LineFlag: bits/1
				bits: next bits
				either LineFlag = #"1" [
					DeltaX: SB-to-int copy/part bits NBits
					bits: skip bits NBits
					DeltaY: SB-to-int copy/part bits NBits
					bits: skip bits NBits
				][
					vertFlag?: #"1" = bits/1
					bits: next bits
					either vertFlag? [
						DeltaY: SB-to-int copy/part bits NBits
						DeltaX: 0
					][
						DeltaX: SB-to-int copy/part bits NBits
						DeltaY: 0
					]
					bits: skip bits NBits
				]
				print [tabs "X-Y:" DeltaX / 20 DeltaY / 20]
			][
				print [tabs "CurvedFlag"]
				CDeltaX: SB-to-int copy/part bits NBits
				bits: skip bits NBits
				CDeltaY: SB-to-int copy/part bits NBits
				bits: skip bits NBits
				add-point CDeltaX CDeltaY
				print [tabs "Control X-Y:" CDeltaX / 20 CDeltaY / 20 ]
				ADeltaX: SB-to-int copy/part bits NBits
				bits: skip bits NBits
				ADeltaY: SB-to-int copy/part bits NBits
				bits: skip bits NBits
				add-point ADeltaX ADeltaY
				print [tabs "Anchor  X-Y:" ADeltaX / 20 ADeltaY / 20 ]
			]
			;probe points
			ind-
		]
	]
]
parse-FILLSTYLEARRAY: func[/local fills type color][
	print [tabs "FillStyleCount:" fills: get-count ]
	if fills > 0 [
		ind+
		loop fills [
			print [tabs "FillStyleType:" type: tag-bin-part 1]
			if type = #{00} [
				color: tag-bin-part either tagid = 32 [4][3]
				print [tabs "Color:" color]
			]
			if found? find #{1012} type [
				print [tabs "Gradient matrix:" ] parse-matrix
				print [tabs "NumGradients:" i: to-integer tag-bin-part 1]
				loop i [
					print [tabs "Ratio:" to-integer tag-bin-part 1]
					print [tabs "Color:" to-tuple tag-bin-part either tagid = 32 [4][3]]
				]
			]
			if found? find #{40414243} type [
				print [tabs switch type [
					#{40} ["tiled"]
					#{41} ["clipped"]
					#{42} ["no sm. tiled"]
					#{43} ["no sm. clipped"]
				] "bitmap" tag-bin-part/rev 2]
				print [tabs "Bitmap matrix:" ] parse-matrix
			]
		]
		ind-
	]
]
parse-LINESTYLEARRAY: func[][
	print [tabs "LineStyleCount:" lines: get-count ]
	if tag-bin/1 > 0 [
		ind+
		loop lines [parse-LINESTYLE]
		ind-
	]
]
parse-LINESTYLE: func[/local width rgb][
	width: bin-to-int tag-bin-part 2
	either tagid = 32 [
		rgb: tag-bin-part 4
	][	rgb: tag-bin-part 3	]
	print [tabs "width:" width "RGB:" rgb]
]

ConstantPool: make block! []

parse-ActionRecord: func[bin-data /init /local vals cp str pstr word dec reg logic i32 ofs][
	ind+
	probe bin-data
	if init [
		print [tabs "For sprite:" copy/part bin-data 2]
		bin-data: skip bin-data 2
	]
	actions: make block! []
aparsers: [
	"ActionGetURL" [
		print [tabs aname mold parse/all data "^@"]
	]
	"ActionConstantPool" [
		ConstantPool: next parse/all data "^@"
		print [tabs aname data mold ConstantPool]
	]
	"ActionIf" [
		ofs: sb-to-int data
		either ofs < 0 [
			print [tabs aname data "(" ofs ")"]
		][
			print [tabs aname]
			parse-ActionRecord bin-part ofs
		]
	]
	"ActionDefineFunction" [
		vals: make block! []
		set [data codeSize] slice-bin data reduce [(length? data) - 2 2]
		parse/all data [str word any [str]]
		print [tabs aname rejoin [vals/1 mold skip vals 2]]
		parse-ActionRecord bin-part bin-to-int codeSize
	]
	"ActionPush" [
		vals: make block! []
		parse/all data [some [cp | i32 | dec | pstr | logic | reg | null]]
		print [tabs aname data mold vals]
	]
]
	cp: ["^H" copy v 1 skip
		(append vals pick ConstantPool v: 1 + str-to-int v)
	]
	i32: ["^G" copy v 4 skip
		(append vals v: str-to-int v)
	]
	pstr: ["^@" copy v to "^@" 1 skip
		(append vals v)
	]
	logic: ["^E" copy v 1 skip
		(append vals pick [false true] 1 + str-to-int v)
	]
	null: ["^B" ( append vals 'null )]
	dec: ["^F" copy v 8 skip
		(append vals bin-to-decimal to-binary v)
	]
	reg: ["^D" copy v 1 skip
		(append vals to-path join "register/" 1 + str-to-int v)
	]
	str: [copy v to "^@" 1 skip (append vals v) ]
	word: [copy v 2 skip (append vals str-to-int v)	]
	actionid: none
	bin-part: func[bytes][b: copy/part bin-data bytes bin-data: skip bin-data bytes b]
	while [all [actionid <> #{00} not empty? bin-data] ][
		actionid: bin-part 1
		length: to-integer either actionid > #{80} [reverse bin-part 2][0]
		data: bin-part length
		aname: select actionids actionid
		switch/default aname aparsers [
			print [tabs aname actionid data]
		]
	]
	ind-
]
	actionids: [
		#{00} "END of ActionRecord"
		;SWF3 Actions
		#{04} "ActionNextFrame"
		#{05} "ActionPrevFrame"
		#{06} "ActionPlay"
		#{07} "ActionStop"
		#{08} "ActionToggleQuality"
		#{09} "ActionStopSounds"
		#{81} "ActionGotoFrame"
		#{83} "ActionGetURL"
		#{8A} "ActionWaitForFrame"
		#{8B} "ActionSetTarget"
		#{8C} "ActionGoToLabel"
		;Stack Operations
		#{96} "ActionPush"
		#{17} "ActionPop"
		;Arithmetic Operators
		#{0A} "ActionAdd"
		#{0B} "ActionSubtract"
		#{0C} "ActionMultiply"
		#{0D} "ActionDivide"
		;Numerical Comparison
		#{0E} "ActionEquals"
		#{0F} "ActionLess"
		;Logical Operators
		#{10} "ActionAnd"
		#{11} "ActionOr"
		#{12} "ActionNot"
		;String Manipulation
		#{13} "ActionStringEquals"
		#{14} "ActionStringLength"
		#{21} "ActionStringAdd"
		#{15} "ActionStringExtract"
		#{29} "ActionStringLess"
		#{31} "ActionMBStringLength"
		#{35} "ActionMBStringExtract"
		;Type Conversion
		#{18} "ActionToInteger"
		#{32} "ActionCharToAscii"
		#{33} "ActionAsciiToChar"
		#{36} "ActionMBCharToAscii"
		#{37} "ActionMBAsciiToChar"
		;Control Flow
		#{99} "ActionJump"
		#{9D} "ActionIf"
		#{9E} "ActionCall"
		;Variables
		#{1C} "ActionGetVariable"
		#{1D} "ActionSetVariable"
		;Movie Control
		#{9A} "ActionGetURL2"
		#{9F} "ActionGotoFrame2"
		#{20} "ActionSetTarget2"
		#{22} "ActionGetProperty"
		#{23} "ActionSetProperty"
		#{24} "ActionCloneSprite"
		#{25} "ActionRemoveSprite"
		#{27} "ActionStartDrag"
		#{28} "ActionEndDrag"
		#{8D} "ActionWaitForFrame2"
		;Utilities
		#{26} "ActionTrace"
		#{34} "ActionGetTime"
		#{30} "ActionRandomNumber"
		;SWF 5
		;ScriptObject Actions
		#{3D} "ActionCallFunction"
		#{52} "ActionCallMethod"
		#{88} "ActionConstantPool"
		#{9B} "ActionDefineFunction"
		#{3C} "ActionDefineLocal"
		#{41} "ActionDefineLocal2"
		#{43} "ActionDefineObject" ;this was not in the specification!
		#{3A} "ActionDelete"
		#{3B} "ActionDelete2"
		#{46} "ActionEnumerate"
		#{49} "ActionEquals2"
		#{4E} "ActionGetMember"
		#{42} "ActionInitArray/Object"
		#{53} "ActionNewMethod"
		#{40} "ActionNewObject"
		#{4F} "ActionSetMember"
		#{45} "ActionTargetPath"
		#{94} "ActionWith"
		;Type Actions
		#{4A} "ActionToNumber"
		#{4B} "ActionToString"
		#{44} "ActionTypeOf"
		;Math Actions
		#{47} "ActionAdd2"
		#{48} "ActionLess2"
		#{3F} "ActionModulo"
		;Stack Operator Actions
		#{60} "ActionBitAnd"
		#{63} "ActionBitLShift"
		#{61} "ActionBitOr"
		#{64} "ActionBitRShift"
		#{65} "ActionBitURShift"
		#{62} "ActionBitXor"
		#{51} "ActionDecrement"
		#{50} "ActionIncrement"
		#{4C} "ActionPushDuplicate"
		#{3E} "ActionReturn"
		#{4D} "ActionStackSwap"
		#{87} "ActionStoreRegister"

		;flashMX Actions
		#{66} "ActionStrictEqual"
	]

parse-swf-header: func[/local sig][
	tag-bin: copy swf-bin
	sig: tag-bin-part 3
	if sig <> #{465753} [
		either sig = #{435753} [
			print "This file is compressed Flash MX file!"
		][	print "Illegal swf header!" halt ]
	]
	swf/header/version: to-integer tag-bin-part 1
	swf/header/length: to-integer tag-bin-part/rev 4
	swf/header/frame-size: get-rect/integers enbase/base tag-bin 2
	tag-bin: skip tag-bin (extend-int skip-val) / 8
	swf/header/frame-rate: to-integer tag-bin-part 2
	swf/header/frame-count: to-integer tag-bin-part/rev 2
	swf-bin: copy tag-bin
]

foreach-tag: func[bin action /local tag length data getpart][
	getpart: func[bytes /rev /local tmp][
		tmp: copy/part bin bytes
		bin: skip bin bytes
		either rev [reverse tmp][tmp]
	]
	tag: none
	bind action 'tag
	while [not tail? bin][
		t: getpart 2
		set [tag length] slice-bin (enbase/base (reverse t) 2) [10 6]
		tag:    to-integer debase/base refill-bits tag 2
		length: to-integer debase/base refill-bits length 2
		;print [tag length]
		if length = 63 [length: to-integer getpart/rev 4]
		probe data: getpart length
		do action
	]
]
show-info: [
	tagid: tag
	t: select swf-tags tag
	either found? t [
		prin rejoin [tabs t/1 "(" tagid "): "]
		either none? t/2 [
			print [tag length data]
		][
			tag-bin: data
			do t/2
		]
	][print [tabs tag length data]]
]

sysprint: get in system/words 'print
sysprin: get in system/words 'prin
exam-swf: func[ /file swf-file [file! url!] /quiet /local f info err][
	;--------[ global variables ]----------
	swf: make object! [
		header: make object! [
			version: none
			length: none
			frame-size: make block! []
			frame-rate: none
			frame-count: none
		]
		rect: none
		data: make block! 10
	]
	obj-id: 0
	indent: 0
	used-bits: 0
	skip-val: none ;how many bits i'll have to skip

	if none? swf-file [
		if empty? swf-file: to-file ask "SWF file:" [swf-file: %new.swf]
	]
	if not exists? swf-file [
		f: join swf-file ".swf"
		either exists? f [swf-file: f][print ["Cannot found the file" swf-file "!"]]
	]
	swf-bin: read/binary swf-file
	if quiet [
		prin: print: func[str][reduce str]
	]
	if error? err: try [
		prin "Searching the binary file... "
		print reform ["swf size:" length? swf-bin "bytes"]
		parse-swf-header
		print "-------------------------"
		probe swf/header
		info: make block! [repend/only swf/data [tag length data]]
		foreach-tag swf-bin append info show-info
		print: :sysprint
		prin: :sysprin
	][
		print: :sysprint
		prin: :sysprin
		throw err
	]

	swf
]


## LDA analysis
library(MASS)
library(ggplot2)
require(gridExtra)
setwd("/home/homero/KDB/Projectes/dakd-project/R")

model.evaluation <- function(dataset){
  accurate <- dataset[ which(dataset$reallabel == dataset$label), ]
  nrow(accurate)
  errors <- dataset[ which(dataset$reallabel != dataset$label),]
  error.rate <- round(nrow(errors)/nrow(dataset) * 100,2)
  return(error.rate)
}

dataset.Stats <- function(x) {
  result <- table(x[,3])
  l <- nrow(x)
  result <- round(result *100/l,0)
  print(result)
  #return(result)
}

csvData <- read.csv(file="data_20171220.csv", header=TRUE, sep=",")

trainData2 <- csvData[c(1:99,200:600,1100:1326),]
testData2 <- csvData[c(100:200,600:1100,1327:1426),]

dataset.Stats(csvData)
dataset.Stats(trainData2)
dataset.Stats(testData2)

#nrow(trainData)
#ncol(trainData)
#names(trainData)

#nrow(trainData2)
#ncol(trainData2)
#names(trainData2)

lda.model2 <- lda(csvData[,3] ~ ., data=csvData[c(8:251)])

table(csvData[,3] )
# labels amb pocs 1, -> eliminar
# >14 ok

lda.prediction <- predict(object = lda.model2, newdata = testData2)
dataset <- data.frame(label=lda.prediction$class, lda=lda.prediction$x, hash=testData2[,4] ,reallabel=testData2[,3])

nrow(dataset)
head(dataset$label)
head(dataset$reallabel)

p1 <- ggplot(dataset, aes(x=lda.LD1, y=lda.LD2, colour=label, shape=reallabel)) +
  geom_point() +
  coord_cartesian(ylim=c(-20,20),xlim=c(-50,50))

p2 <- ggplot(dataset, aes(x=lda.LD1, y=lda.LD3, colour=label, shape=reallabel)) +
  geom_point() +
  coord_cartesian(ylim=c(-20,20),xlim=c(-50,50))

p3 <- ggplot(dataset, aes(x=lda.LD1, y=lda.LD4, colour=label, shape=reallabel)) +
  geom_point() +
  coord_cartesian(ylim=c(-20,20),xlim=c(-50,50))

p4 <- ggplot(dataset, aes(x=lda.LD2, y=lda.LD3, colour=label, shape=reallabel)) +
  geom_point() +
  coord_cartesian(ylim=c(-20,20),xlim=c(-50,50))

p5 <- ggplot(dataset, aes(x=lda.LD2, y=lda.LD4, colour=label, shape=reallabel)) +
  geom_point() +
  coord_cartesian(ylim=c(-20,20),xlim=c(-50,50))

p6 <- ggplot(dataset, aes(x=lda.LD3, y=lda.LD4, colour=label, shape=reallabel)) +
  geom_point() +
  coord_cartesian(ylim=c(-20,20),xlim=c(-25,25))

grid.arrange(p1,p2,p3,p4,p5,p6)
grid.arrange(p4,p6)
p6

table(dataset[,2])

# data cleaning
#  empty groups -> filter out
#  test with 2, 3 main classes

# data mining alg:
# FDA is not suitable for sparse interger matrix
# 0) percentages? -> real number + somehow reduce sparsity
# 1) iterar els pca's creant clasif fins que rendiment baixi ( # 30ena  i reals)
# 2) embedding (software: gensim embedding)
# 3) svm
# 4) psa


library(FLCore)
#library(FLAssess)
 #  library(FLEDA)
if (allLibraries) {
  #ibrary(FLXSA)
  #library(FLBRP)
  #library(FLHCR)
  #library(FLEDA)

 }

do.test<-FALSE

#library(FLSMS)

#overwrite FLSMS library
source(file.path(my.FLR.path,"flsms.control.r"))
source(file.path(my.FLR.path,"flsms.predict.control.r"))

source(file.path(my.FLR.path,"flstockmulti.r"))
source(file.path(my.FLR.path,"flindex.sms.r"))
source(file.path(my.FLR.path,"xsa2sms.r"))
source(file.path(my.FLR.path,"sms2flsmss.r"))

source(file.path(my.FLR.path,"flsms.r"))
source(file.path(my.FLR.path,"flsmss.r"))

source(file.path(my.FLR.path,"flop.control.r"))
source(file.path(my.FLR.path,"flop_msfd.control.r"))


library(Seurat)
library(ggplot2)
library(Matrix)

#SLE flare data read in
#can be accessed through https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE137029
mm<-readMM('./project/sle_flare_GSE137029/matrix.mtx.gz')
features=read.table('./project/sle_flare_GSE137029/features.tsv.gz',sep='\t')
bar<-read.table('./project/sle_flare_GSE137029/barcodes.tsv.gz',sep='\t')
rownames(mm)<-bar$V1
colnames(mm)<-features$V1
sle<-CreateSeuratObject(counts=t(mm),project='sle')

#HD Sample
##can be accessed through https://cells.ucsc.edu/?ds=multimodal-pbmc+sct data download page
##hd rds
##first time processing hd data please run following step for first hd data processing
##mat <- fread("exprMatrix.tsv.gz")
##meta <- read.table("meta.tsv", header=T, sep="\t", as.is=T, row.names=1)
##genes = mat[,1][[1]]
##genes = gsub(".+[|]", "", genes)
##mat = data.frame(mat[,-1], row.names=genes)
##hd <- CreateSeuratObject(counts = mat, project = "hd", meta.data=meta)
##hd@meta.data$orig.ident<-'hd'
##saveRDS(hd,ucsc_pbmc_hd.rds)
hd<-readRDS('./project/ucsc_pbmc_hd.rds')

####child sle used datasets
path<-'./project/GSE135779_SLE/cSLE/SLE_HEAVY/'
file<-dir(path)
file

file.path<-lapply(file,function(x){
    paste(path,x,sep='')
})
csle_heavy<-list()
for(i in 1:length(file.path)){
    csle_heavy[[i]]<-Read10X(file.path[[i]])
    csle_heavy[[i]]<-CreateSeuratObject(csle_heavy[[i]],project='csle_heavy')
    csle_heavy[[i]]@meta.data$orig.ident<-'csle_heavy'

}

csle_heavy_m<-csle_heavy[[1]]
for(i in 2:length(csle_heavy)){
    csle_heavy_m<-merge(csle_heavy_m,csle_heavy[[i]])
}

sle<-merge(sle,csle_heavy_m)

data.list<-list(sle,hd)
data.list <- lapply(X = data.list, FUN = function(x) {
    x <- NormalizeData(x, verbose = FALSE)
    x <- FindVariableFeatures(x, verbose = FALSE)
})
features <- SelectIntegrationFeatures(object.list = data.list)
data.list <- lapply(X = data.list, FUN = function(x) {
    x <- ScaleData(x, features = features, verbose = FALSE)
    x <- RunPCA(x, features = features, verbose = FALSE)
})
anchors <- FindIntegrationAnchors(object.list = data.list, reference = c(1,2), reduction = "rpca",
    dims = 1:50)
data.integrated <- IntegrateData(anchorset = anchors, dims = 1:50)
data.integrated <- ScaleData(data.integrated, verbose = FALSE)
data.integrated <- RunPCA(data.integrated, verbose = FALSE)
data.integrated <- RunUMAP(data.integrated, dims = 1:50)
data.integrated<-FindNeighbors(data.integrated,dims=1:50)

DefaultAssay(data.integrated)<-'integrated'
data.integrated<-FindClusters(data.integrated,res=0.2)

DimPlot(data.integrated,group.by=c('seurat_clusters','celltype.l1'),label=T,raster=F)

new.cluster.ids <- c("T", "Mono", "T", "T", "B", "NK",
    "Mono", "Mono", "Mono",'DC','other','DC','other','T','other','T','other','DC','B','other')
names(new.cluster.ids) <- levels(data.integrated)
data.integrated <- RenameIdents(data.integrated, new.cluster.ids)
DimPlot(data.integrated, reduction = "umap", label = TRUE, pt.size = 0.5) + NoLegend()

saveRDS(data.integrated,'./project/sle_nature_communiation_and_immunnology_merge_include_hd.rds')


# trace plots for bach
# add TF plot
# trace_plots11.r - modify colours to match boxplots

# library(MASS)
library(robustbase)
library(tidyverse)
library(cowplot)
library(scales) # for dates
library(rkt) # Mann-Kendall test
library(lubridate)
library(lfstat)
library(FlowScreen)
library(RColorBrewer)
library(naniar)
library(EGRET) # UGSG trend software

# path for output
# out_path <- 'run - eckhardt_priors_narrow/'
print(out_path)

##### read in data ####
source("read_data9.r")
nruns <- nrow(runlist)

# choose rows to run
rows <- 1:nruns # to run all sites
ah <- vector("list", nruns) # all hydrographs
# rows <- c(20,21) # to run a subset of sites, useful for testing
# i <- rows[[10]]

#### loop through data sets ####
i <- rows[1]
for (i in rows) {

  # set axis options for each set
  if (i %in% c(1, 9, 17)) { # Tahuna
    TPlimits <- c(0, 0.4)
    TPbreaks <- seq(0, 0.8, 0.2)
    TNlimits <- c(0, 6)
    TNbreaks <- seq(0, 6, 2)
    flowlimits <- c(0, 20)
    flowbreaks <- seq(0, 20, 5)
  } else if (i %in% c(2, 10, 18)) { # Otama
    TPlimits <- c(0, 0.4)
    TPbreaks <- seq(0, 0.8, 0.2)
    TNlimits <- c(0, 6)
    TNbreaks <- seq(0, 6, 2)
    flowlimits <- c(0, 5)
    flowbreaks <- seq(0, 5, 1)
  } else if (i %in% c(3, 11, 19)) { # Waiotapu
    TPlimits <- c(0, 0.4)
    TPbreaks <- seq(0, 0.8, 0.2)
    TNlimits <- c(0, 6)
    TNbreaks <- seq(0, 6, 2)
    flowlimits <- c(0, 10)
    flowbreaks <- seq(0, 10, 2)
  } else if (i %in% c(4, 12, 20)) { # Pokai
    TPlimits <- c(0, 0.4)
    TPbreaks <- seq(0, 0.8, 0.2)
    TNlimits <- c(0, 6)
    TNbreaks <- seq(0, 6, 2)
    flowlimits <- c(0, 20)
    flowbreaks <- seq(0, 20, 5)
  } else if (i %in% c(5, 13, 21)) { # Piako
    TPlimits <- c(0, 0.4)
    TPbreaks <- seq(0, 0.8, 0.2)
    TNlimits <- c(0, 6)
    TNbreaks <- seq(0, 6, 2)
    flowlimits <- c(0, 8)
    flowbreaks <- seq(0, 8, 2)
  } else if (i %in% c(6, 14, 22)) { # Waitoa
    TPlimits <- c(0, 0.4)
    TPbreaks <- seq(0, 0.8, 0.2)
    TNlimits <- c(0, 6)
    TNbreaks <- seq(0, 6, 2)
    flowlimits <- c(0, 8)
    flowbreaks <- seq(0, 8, 2)
  } else if (i %in% c(7, 15, 23)) { # Waihou
    TPlimits <- c(0, 0.4)
    TPbreaks <- seq(0, 0.8, 0.2)
    TNlimits <- c(0, 6)
    TNbreaks <- seq(0, 6, 2)
    flowlimits <- c(0, 80)
    flowbreaks <- seq(0, 80, 20)
  } else if (i %in% c(8, 16, 24)) { # Puniu
    TPlimits <- c(0, 0.4)
    TPbreaks <- seq(0, 0.8, 0.2)
    TNlimits <- c(0, 6)
    TNbreaks <- seq(0, 6, 2)
    flowlimits <- c(0, 60)
    flowbreaks <- seq(0, 60, 20)
  } else {
    stop()
  }

  dTPlimits <- c(-0.1, 0.1)
  dTPbreaks <- seq(-0.1, 0.1, 0.05)
  dTNlimits <- c(-1, 1)
  dTNbreaks <- seq(-1, 1, 0.5)

  # rough estimate for total flow (TF)
  TFlimits <- flowlimits * 1
  TFbreaks <- flowbreaks * 1

  data_file_name <- paste(runlist$catchfile[i], "_data.dat", sep = "")
  opt_file_name <- runlist$optfile[i]
  print(paste(data_file_name, "+", opt_file_name))

  # assemble run options/data into vectors (?)
  arun <- runlist[i, ]
  adata <- data[grep(pattern = data_file_name, x = data$file), ]
  aarea <- tibble(area = adata$area[1])
  aoptions <- options[opt_file_name, ]
  aalloptions <- cbind(arun, aoptions, aarea) # combine into one data table
  startcalib <- aalloptions$startcalib
  endcalib <- aalloptions$endcalib
  catchname <- aalloptions$catchname %>% print()
  setname <- aalloptions$setname
  keeps <- c("startrun", "startcalib", "endcalib", "startvalid", "endvalid")
  intoptions <- as.vector(t(aalloptions[keeps]))
  nintoptions <- length(intoptions)
  keeps <- c("chem1ae", "chem1re", "chem2ae", "chem2re", "area")
  realoptions <- as.vector(t(aalloptions[keeps]))
  nrealoptions <- length(realoptions)
  date <- as.vector(adata$date)
  ndate <- length(date)
  flow <- as.vector(adata$flow)
  TP <- as.vector(adata$TP)
  TN <- as.vector(adata$TN)
  meanTPcalib <- mean(TP[startcalib:endcalib], na.rm = TRUE)
  meanTNcalib <- mean(TN[startcalib:endcalib], na.rm = TRUE)
  meanTFcalib <- mean(flow[startcalib:endcalib])
  TP[is.na(TP)] <- -1 # stan doesn't understand NA
  TN[is.na(TN)] <- -1 # stan doesn't understand NA

  # add flow info
  adata <- adata %>%
    mutate(
      x = rep(1:ndate, times = 1),
      xdate = as.Date(date, origin = "1899-12-30"),
      TF = flow
    )

  # define date range
  fromdate <- as.Date(intoptions[2], origin = "2000-12-31")
  todate <- as.Date(intoptions[3], origin = "2000-12-31")
  daterange <- c(fromdate, todate)

  #### do hydrograph ####

  # get hydrograph
  y0 <- adata %>%
    mutate(pc = "data") %>%
    select(pc, TF, x, xdate) %>%
    filter(x %in% c(startcalib:endcalib)) %>%
    mutate(
      flow = TF,
      day = day(xdate),
      month = month(xdate),
      year = year(xdate)
    )
  ldata <- createlfobj(y0, hyearstart = 1) # does baseflow separation
  y0$baseflow <- ldata$baseflow
  bfi <- BFI(ldata)
  print(paste("BFI Fixed    =", bfi))
  y0$baseflow2 <- bf_eckhardt(y0$flow, 0.98, 0.8)
  bfi2 <- sum(y0$baseflow2) / sum(y0$flow)
  print(paste("BFI Eckhardt =", bfi2))

  p0 <- ggplot() +
    labs(title = "", y = "Flow " ~ (m^3 ~ s^{-1}), x = "", colour = "Percentile") +
    theme_cowplot() +
    theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
    panel_border(colour = "black") +
    # scale_colour_manual(values=c('orchid','darkorchid','darkmagenta','darkorchid','orchid')) +
    scale_colour_manual(values = c("black", "black", "black", "black", "black")) +
    scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
    scale_y_continuous(expand = c(0, 0), breaks = TFbreaks) +
    coord_cartesian(ylim = TFlimits) +
    # geom_ribbon(data=y0, mapping=aes(x=xdate, ymin=TF-0.2*tci*TF, ymax=TF+0.2*tci*TF), colour='lightgrey', fill='lightgrey') +
    geom_line(data = y0, mapping = aes(x = xdate, y = TF, colour = pc))
  aah <- p0 +
    annotate(geom = "label", x = min(y0$xdate) + 120, y = max(TFlimits) * 0.8, label = setname, size = 4) +
    # geom_line(data=y0, mapping=aes(x=xdate, y=baseflow2), colour="red") +
    labs(y = "")
  # print(aah)

  # now do stuff that only applies to data sets that have chem data
  file_name <- paste(out_path, setname, "_traces.rds", sep = "")
  if (file.exists(file_name)) {

    # Murdoch and Shanley trend analysis
    if (FALSE) {
      print("Mudoch and Shanley trend analysis")
      tdata <- adata %>%
        select(shortname, TF, TP, TN, x, xdate) %>%
        filter(x %in% c(startcalib:endcalib)) %>%
        mutate(
          day = day(xdate),
          month = month(xdate),
          year = year(xdate)
        )
      qflows <- quantile(tdata$TF, c(0.05, 0.50, 0.95))
      tyear <- tibble(year = unique(tdata$year)) %>%
        mutate(
          shortname = tdata$shortname[1],
          TP05 = NA_real_,
          TP50 = NA_real_,
          TP95 = NA_real_,
          TN05 = NA_real_,
          TN50 = NA_real_,
          TN95 = NA_real_
        )
      j <- 1
      for (j in 1:nrow(tyear)) {
        tdatai <- tdata %>%
          filter(year == tyear$year[j]) %>%
          drop_na()
        # modelTP <- loess(TP ~ TF, data = tdatai, control = loess.control(surface = "interpolate"))
        # modelTN <- loess(TN ~ TF, data = tdatai, control = loess.control(surface = "interpolate"))
        if (nrow(tdatai) > 3) {
          modelTP <- lm(TP ~ poly(TF, 3), data = tdatai)
          modelTN <- lm(TN ~ poly(TF, 3), data = tdatai)
          tdatai$modelTP <- predict(modelTP, tdatai)
          tdatai$modelTN <- predict(modelTN, tdatai)
          ggplot(tdatai) +
            geom_point(mapping = aes(x = TF, y = TP)) +
            geom_line(mapping = aes(x = TF, y = modelTP), colour = "red")
          ggplot(tdatai) +
            geom_point(mapping = aes(x = TF, y = TN)) +
            geom_line(mapping = aes(x = TF, y = modelTN), colour = "blue")
          tyear$TP05[j] <- predict(modelTP, data.frame(TF = qflows[1]))
          tyear$TP50[j] <- predict(modelTP, data.frame(TF = qflows[2]))
          tyear$TP95[j] <- predict(modelTP, data.frame(TF = qflows[3]))
          tyear$TN05[j] <- predict(modelTN, data.frame(TF = qflows[1]))
          tyear$TN50[j] <- predict(modelTN, data.frame(TF = qflows[2]))
          tyear$TN95[j] <- predict(modelTN, data.frame(TF = qflows[3]))
        }
      }
      ggplot(tyear) +
        labs(title = paste(tyear$shortname[1], "TP")) +
        geom_line(mapping = aes(x = year, y = TP05), colour = "blue") +
        geom_line(mapping = aes(x = year, y = TP50), colour = "green") +
        geom_line(mapping = aes(x = year, y = TP95), colour = "red")
      ggplot(tyear) +
        labs(title = paste(tyear$shortname[1], "TN")) +
        geom_line(mapping = aes(x = year, y = TN05), colour = "blue") +
        geom_line(mapping = aes(x = year, y = TN50), colour = "green") +
        geom_line(mapping = aes(x = year, y = TN95), colour = "red")
    }

    # USGS trend analysis
    if (TRUE) {
      print("USGS trend analysis")
      tdata <- adata %>%
        select(shortname, TF, TP, TN, x, xdate) %>%
        filter(x %in% c(startcalib:endcalib)) %>%
        mutate(
          day = day(xdate),
          month = month(xdate),
          year = year(xdate)
        )
      # convert my data to EGRET format
      Solute <- "TP"
      Solute <- "TN"
      wrtds <- list()
      for (Solute in c("TP", "TN")) {
        Daily <- data.frame(Date = tdata$xdate, Flow = tdata$TF)
        write_csv(Daily, "temp_egret_daily.csv")
        Daily <- readUserDaily(getwd(), "temp_egret_daily.csv", qUnit = 2, verbose = FALSE)
        Sample <- data.frame(Date = tdata$xdate, Remark = "", Conc = tdata[[Solute]]) %>% drop_na()
        write_csv(Sample, "temp_egret_sample.csv")
        Sample <- readUserSample(getwd(), "temp_egret_sample.csv")
        INFO <- data.frame(
          param.units = "mg/L",
          shortName = aalloptions$catchname,
          paramShortName = Solute,
          drainSqKm = aalloptions$area,
          constitAbbrev = Solute,
          staAbbrev = tdata$shortname[1],
          paStart = 1,
          paLong = 12,
          queryTime = Sys.time(),
          stringsAsFactors = FALSE
        )
        write_csv(INFO, "temp_egret_info.csv")
        INFO <- readUserInfo(getwd(), "temp_egret_info.csv", interactive = FALSE)
        eList <- mergeReport(INFO, Daily, Sample, verbose = FALSE)
        # plots and analysis
        eList <- modelEstimation(eList, verbose = FALSE, minNumObs = 60, minNumUncen = 30)
        if (tdata$shortname[1] %in% c("Ot", "Wp") && Solute %in% "TP"){
          # handle missing TP data, see EGRET manual p49
          eList <- blankTime(eList, "2004-12-21", "2011-10-25") # deletes poor data period
        }
        if (FALSE){
          multiPlotDataOverview(eList)
          plotConcTimeDaily(eList)
          plotConcPred(eList)
          plotResidPred(eList)
          plotResidQ(eList)
          plotResidTime(eList)
          boxResidMonth(eList)
          plotConcHist(eList)
          plotFluxHist(eList)
        }
        q1 <- quantile(eList$Daily$Q, 0.05)
        q2 <- quantile(eList$Daily$Q, 0.5)
        q3 <- quantile(eList$Daily$Q, 0.95)
        centerDate <- "07-01"
        yearStart <- eList$INFO$DecLow
        yearEnd <- eList$INFO$DecHigh
        # capture output of plot
        # print(Solute)
        wrtdscol <- "grey"
        wrtds[[Solute]] <- plotConcTimeSmooth(eList, q1, q2, q3, centerDate, yearStart, yearEnd,
                                              printValues = TRUE,
                                              minNumObs = 60,
                                              minNumUncen = 30,
                                              windowY = 5) %>% # key!
          setNames(c("year", "low", "med", "high")) %>%
          mutate(date = ymd(paste0(floor(year), centerDate)))
        if (FALSE){
          fluxBiasMulti(eList)
          clevel <- pretty(range(eList$Sample$ConcAve))
          qlevel <- 10^pretty(log10(range(eList$Daily$Q)))
          plotContours(eList, yearStart, yearEnd, qBottom = qlevel[1], qTop = qlevel[length(qlevel)], contourLevels = clevel)
          plotDiffContours(eList, year0 = yearStart, year1 = yearEnd, qBottom = qlevel[1], qTop = qlevel[length(qlevel)], maxDiff = diff(range(eList$Sample$ConcAve)))
        }
      }
    }

    # read traces
    traces <- read_rds(file_name)

    # read quartiles from previous run to compare
    # old_path <- "../bach_constant/run - eckhardt_priors_narrow/"
    old_path <- paste0(out_path, "/old_quartiles/")
    old_quartiles <- paste0(old_path, aalloptions$setname, "_quartiles.rds")
    old_quartiles <- str_replace(old_quartiles, "\\(x\\)", c("(a)", "(b)", "(c)"))
    old_fits <- vector("list", 3)
    old_fits[[1]] <- readRDS(old_quartiles[1]) %>%
      mutate(xdate = dmy("1-July-2004")) %>%
      slice(4:8)
    if (file.exists(old_quartiles[2])) {
      old_fits[[2]] <- readRDS(old_quartiles[2]) %>%
        mutate(xdate = dmy("1-July-2009")) %>%
        slice(4:8)
    } else {
      old_fits[[2]] <- readRDS(old_quartiles[1]) %>%
        replace_with_na_all(~TRUE) %>%
        mutate(xdate = dmy("1-July-2009")) %>%
        slice(4:8)
    }
    old_fits[[3]] <- readRDS(old_quartiles[3]) %>%
      mutate(xdate = dmy("1-July-2014")) %>%
      slice(4:8)
    old_box <- bind_rows(old_fits) %>% mutate(pc = rep(c("2.5%", "25%", "50%", "75%", "97.5%"), 3))

    # this is probably a better approach, use a single data frame for all variables
    # temp <- traces %>%
    #   select('2.5%', '25%', '50%', '75%', '97.5%') %>%
    #   mutate(name=rownames(traces)) %>%
    #   gather('2.5%', '25%', '50%', '75%', '97.5%', key='pc', value='val') %>%
    #   mutate(var=rep(c('Fast', 'Medium', 'Slow', 'TP', 'TN'), times=ndate*5),
    #          date=rep(1:ndate, each=5, times=5))

    sort <- c(1, 5, 2, 4, 3)
    # tpcol <- c('chartreuse','green','seagreen','green','chartreuse')
    # tncol <- c('pink','red','darkred','red','pink')
    # fcol <- c('orange','firebrick','darkorange','firebrick','orange')
    # mcol <- c('deepskyblue','blue','darkblue','blue','deepskyblue')
    # scol <- c('orchid','darkorchid','darkmagenta','darkorchid','orchid')
    choose <- c(3, 5, 7, 5, 3)
    tpcol <- brewer.pal(9, "OrRd")[choose]
    tncol <- brewer.pal(9, "YlGn")[choose]
    fcol <- brewer.pal(9, "YlOrBr")[choose - 1]
    mcol <- brewer.pal(9, "PuBu")[choose + 1]
    scol <- brewer.pal(9, "RdPu")[choose + 1]

    keeps <- grep(",3]", rownames(traces), invert = FALSE)
    y3 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "Slow") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))

    keeps <- grep(",2]", rownames(traces), invert = FALSE)
    y2 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "Medium") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib)) %>%
      mutate(Medium = Medium - y3$Slow)

    keeps <- grep(",1]", rownames(traces), invert = FALSE)
    y1 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "Fast") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib)) %>%
      mutate(Fast = Fast - y2$Medium - y3$Slow)

    # keeps <- grep(',1]', rownames(traces), invert=FALSE)
    # y6 <- as_tibble(traces[keeps,]) %>%
    #   select('2.5%', '25%', '50%', '75%', '97.5%') %>%
    #   gather('2.5%', '25%', '50%', '75%', '97.5%', key='pc', value='TF') %>%
    #   mutate(x=rep(1:ndate, times=5),
    #          xdate=as.Date(x, origin='2000-12-31')) %>%
    #   filter(x %in% c(startcalib:endcalib))

    keeps <- grep(",4]", rownames(traces), invert = FALSE)
    y4 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "TP") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib)) %>%
      group_by(x) %>%
      mutate(
        TPmed = median(TP),
        TPmin = min(TP),
        TPmax = max(TP),
        TPr = TP - TPmed
      )

    y4s <- y4 %>%
      select(x, xdate, pc, TP) %>%
      pivot_wider(names_from = pc, values_from = TP) %>%
      mutate(
        TPmed = `50%`,
        TPmin = `2.5%`,
        TPmax = `97.5%`,
        TF = y0$TF[y0$x == x]
      )

    adata <- adata %>%
      group_by(x) %>%
      mutate(
        TPmed = median(y4$TP[y4$x == x]),
        TPr = TP - TPmed
      )

    keeps <- grep(",5]", rownames(traces), invert = FALSE)
    y5 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "TN") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib)) %>%
      group_by(x) %>%
      mutate(
        TNmed = median(TN),
        TNmin = min(TN),
        TNmax = max(TN),
        TNr = TN - TNmed
      )

    y5s <- y5 %>%
      select(x, xdate, pc, TN) %>%
      pivot_wider(names_from = pc, values_from = TN) %>%
      mutate(
        TNmed = `50%`,
        TNmin = `2.5%`,
        TNmax = `97.5%`,
        TF = y0$TF[y0$x == x]
      )

    adata <- adata %>%
      group_by(x) %>%
      mutate(
        TNmed = median(y5$TN[y5$x == x]),
        TNr = TN - TNmed
      )

    keeps <- grep(",6]", rownames(traces), invert = FALSE)
    y6 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "fastTP") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))
    keeps <- grep(",12]", rownames(traces), invert = FALSE)
    y12 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "dfastTP") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))

    keeps <- grep(",7]", rownames(traces), invert = FALSE)
    y7 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "medTP") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))
    keeps <- grep(",13]", rownames(traces), invert = FALSE)
    y13 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "dmedTP") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))

    keeps <- grep(",8]", rownames(traces), invert = FALSE)
    y8 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "slowTP") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))
    keeps <- grep(",14]", rownames(traces), invert = FALSE)
    y14 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "dslowTP") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))

    keeps <- grep(",9]", rownames(traces), invert = FALSE)
    y9 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "fastTN") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))
    keeps <- grep(",15]", rownames(traces), invert = FALSE)
    y15 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "dfastTN") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))

    keeps <- grep(",10]", rownames(traces), invert = FALSE)
    y10 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "medTN") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))
    keeps <- grep(",16]", rownames(traces), invert = FALSE)
    y16 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "dmedTN") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))

    keeps <- grep(",11]", rownames(traces), invert = FALSE)
    y11 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "slowTN") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))
    keeps <- grep(",17]", rownames(traces), invert = FALSE)
    y17 <- as_tibble(traces[keeps, ]) %>%
      select("2.5%", "25%", "50%", "75%", "97.5%") %>%
      gather("2.5%", "25%", "50%", "75%", "97.5%", key = "pc", value = "dslowTN") %>%
      mutate(
        x = rep(1:ndate, times = 5),
        xdate = as.Date(x, origin = "2000-12-31"),
        pc = factor(pc, levels = c("2.5%", "25%", "50%", "75%", "97.5%")[sort], ordered = TRUE)
      ) %>%
      filter(x %in% c(startcalib:endcalib))

    ##### plot chem trace ####
    tci <- qt(.975, 7) # how many s.e. for 95% c.i.

    p4 <- ggplot() +
      labs(title = "", y = "TP " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = TPbreaks) +
      coord_cartesian(ylim = TPlimits) +
      geom_ribbon(data = y4s, mapping = aes(x = xdate, ymin = TPmin - 0.02 * tci, ymax = TPmax + 0.02 * tci), colour = "lightgrey", fill = "lightgrey") +
      # geom_ribbon(data=y4s, mapping=aes(x=xdate, ymin=TPmin, ymax=TPmax), colour=tpcol[1], fill=tpcol[1]) +
      # geom_ribbon(data=y4s, mapping=aes(x=xdate, ymin=`25%`, ymax=`75%`), colour=tpcol[2], fill=tpcol[2]) +
      # geom_line(data=y4s, mapping=aes(x=xdate, y=TPmed), colour=tpcol[3]) +
      geom_line(data = y4, mapping = aes(x = xdate, y = TP, colour = pc)) +
      geom_point(data = adata, mapping = aes(x = xdate, y = TP))

    p4r <- ggplot() +
      labs(title = "", y = "TP residual " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      geom_ribbon(data = y4s, mapping = aes(x = xdate, ymin = TPmin - TPmed - 0.02 * tci, ymax = TPmax - TPmed + 0.02 * tci), colour = "lightgrey", fill = "lightgrey") +
      geom_ribbon(data = y4s, mapping = aes(x = xdate, ymin = TPmin - TPmed, ymax = TPmax - TPmed), colour = tpcol[1], fill = tpcol[1]) +
      geom_ribbon(data = y4s, mapping = aes(x = xdate, ymin = `25%` - TPmed, ymax = `75%` - TPmed), colour = tpcol[2], fill = tpcol[2]) +
      geom_line(data = y4s, mapping = aes(x = xdate, y = 0), colour = tpcol[3]) +
      geom_point(data = adata, mapping = aes(x = xdate, y = TPr))

    robust <- function(formula, data, weights = weight) {
      rlm(formula, data, weights = weight, method = "M")
    }

    # y4s <- y4s %>%
    #   filter(xdate >= dmy("01012005"))

    p4r2 <- ggplot() +
      labs(title = "", y = "TP " ~ (mg ~ L^{-1}), x = "Model Median TP " ~ (mg ~ L^{-1}), colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      # scale_x_date(limits=daterange, date_labels='%Y', date_breaks='1 year') +
      # scale_y_continuous(expand=c(0, 0), breaks=TPbreaks) +
      # coord_cartesian(ylim=TPlimits) +
      geom_ribbon(data = y4s, mapping = aes(x = TPmed, ymin = TPmin - 0.02 * tci, ymax = TPmax + 0.02 * tci), colour = "lightgrey", fill = "lightgrey") +
      geom_ribbon(data = y4s, mapping = aes(x = TPmed, ymin = TPmin, ymax = TPmax), colour = tpcol[1], fill = tpcol[1]) +
      geom_ribbon(data = y4s, mapping = aes(x = TPmed, ymin = `25%`, ymax = `75%`), colour = tpcol[2], fill = tpcol[2]) +
      geom_line(data = y4s, mapping = aes(x = TPmed, y = TPmed), colour = tpcol[3]) +
      # geom_smooth(data=adata, mapping=aes(x=TPmed, y=TP), linetype=2, colour="black", method="loess") +
      geom_point(data = adata, mapping = aes(x = TPmed, y = TP))

    flow_trans <- function() {
      # trans_new("flow", function(x) y=x, function(y) x=y)
      trans_new("flow", function(x) {
        y <- -1 / x
      }, function(y) {
        x <- -1 / y
      })
    }

    flow_breaks <- function(x) {
      r <- range(x)
      r <- r[r > 0 & is.finite(r)]
      round(rev(pretty(rev(r)^-1)^-1), 2)
      # b <- floor(log10(min(x))):ceiling(log10(max(x)))
      # b <- tcrossprod(10^b, c(1,2,5))
      # b <- sort(b)
      # b[b>=min(x) & b<=max(x)]
    }

    p4r3 <- ggplot() +
      labs(title = "", y = "TP " ~ (mg ~ L^{-1}), x = "Flow " ~ (m^3 ~ s^{-1}), colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      # scale_x_date(limits=daterange, date_labels='%Y', date_breaks='1 year') +
      # scale_x_log10() +
      scale_x_continuous(limits = range(adata$TF), breaks = flow_breaks(adata$TF)) +
      # scale_x_continuous(limits = range(adata$TF[!is.na(adata$TP)])) +
      coord_trans(x = "flow") +
      # scale_y_continuous(expand=c(0, 0), breaks=TPbreaks) +
      # coord_cartesian(ylim=TPlimits) +
      geom_ribbon(data = y4s, mapping = aes(x = TF, ymin = TPmin - 0.02 * tci, ymax = TPmax + 0.02 * tci), colour = "lightgrey", fill = "lightgrey") +
      geom_ribbon(data = y4s, mapping = aes(x = TF, ymin = TPmin, ymax = TPmax), colour = tpcol[1], fill = tpcol[1]) +
      geom_ribbon(data = y4s, mapping = aes(x = TF, ymin = `25%`, ymax = `75%`), colour = tpcol[2], fill = tpcol[2]) +
      geom_line(data = y4s, mapping = aes(x = TF, y = TPmed), colour = tpcol[3]) +
      # geom_smooth(data=adata, mapping=aes(x=TPmed, y=TP), linetype=2, colour="black", method="loess") +
      geom_point(data = adata, mapping = aes(x = TF, y = TP))

    p4r4 <- ggplot() +
      labs(title = "", y = "TP residual " ~ (mg ~ L^{-1}), x = "Flow " ~ (m^3 ~ s^{-1}), colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      # scale_x_date(limits=daterange, date_labels='%Y', date_breaks='1 year') +
      # scale_x_log10() +
      scale_x_continuous(limits = range(adata$TF), breaks = flow_breaks(adata$TF)) +
      # scale_x_continuous(limits = range(adata$TF[!is.na(adata$TP)])) +
      coord_trans(x = "flow") +
      # scale_y_continuous(expand=c(0, 0), breaks=TPbreaks) +
      # coord_cartesian(ylim=TPlimits) +
      geom_ribbon(data = y4s, mapping = aes(x = TF, ymin = TPmin - TPmed - 0.02 * tci, ymax = TPmax - TPmed + 0.02 * tci), colour = "lightgrey", fill = "lightgrey") +
      geom_ribbon(data = y4s, mapping = aes(x = TF, ymin = TPmin - TPmed, ymax = TPmax - TPmed), colour = tpcol[1], fill = tpcol[1]) +
      geom_ribbon(data = y4s, mapping = aes(x = TF, ymin = `25%` - TPmed, ymax = `75%` - TPmed), colour = tpcol[2], fill = tpcol[2]) +
      geom_line(data = y4s, mapping = aes(x = TF, y = TPmed - TPmed), colour = tpcol[3]) +
      # geom_smooth(data=adata, mapping=aes(x=TPmed, y=TP), linetype=2, colour="black", method="loess") +
      geom_point(data = adata, mapping = aes(x = TF, y = TP - TPmed))

    p6 <- ggplot() +
      labs(title = "", y = "fTP " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = TPbreaks) +
      coord_cartesian(ylim = TPlimits) +
      geom_point(data = old_box, mapping = aes(x = xdate, y = chem1fast), shape = 1) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = low), colour = wrtdscol, linetype = 2) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = med), colour = wrtdscol, linetype = 5) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = high), colour = wrtdscol, linetype = 6) +
      geom_line(data = y6, mapping = aes(x = xdate, y = fastTP, colour = pc))
    p12 <- ggplot() +
      labs(title = "", y = "dfTP ", x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = dTPbreaks) +
      coord_cartesian(ylim = dTPlimits) +
      geom_hline(yintercept = 0) +
      geom_line(data = y12, mapping = aes(x = xdate, y = dfastTP / 15, colour = pc))

    p7 <- ggplot() +
      labs(title = "", y = "mTP " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = TPbreaks) +
      coord_cartesian(ylim = TPlimits) +
      geom_point(data = old_box, mapping = aes(x = xdate, y = chem1med), shape = 1) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = low), colour = wrtdscol, linetype = 2) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = med), colour = wrtdscol, linetype = 5) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = high), colour = wrtdscol, linetype = 6) +
      geom_line(data = y7, mapping = aes(x = xdate, y = medTP, colour = pc))
    p13 <- ggplot() +
      labs(title = "", y = "dmTP ", x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = dTPbreaks) +
      coord_cartesian(ylim = dTPlimits) +
      geom_hline(yintercept = 0) +
      geom_line(data = y13, mapping = aes(x = xdate, y = dmedTP / 15, colour = pc))

    p8 <- ggplot() +
      labs(title = "", y = "sTP " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = TPbreaks) +
      coord_cartesian(ylim = TPlimits) +
      geom_point(data = old_box, mapping = aes(x = xdate, y = chem1slow), shape = 1) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = low), colour = wrtdscol, linetype = 2) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = med), colour = wrtdscol, linetype = 5) +
      geom_line(data = wrtds[["TP"]], mapping = aes(x = date, y = high), colour = wrtdscol, linetype = 6) +
      geom_line(data = y8, mapping = aes(x = xdate, y = slowTP, colour = pc))
    p14 <- ggplot() +
      labs(title = "", y = "dsTP ", x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      # scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
      scale_colour_manual(values = tpcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = dTPbreaks) +
      coord_cartesian(ylim = dTPlimits) +
      geom_hline(yintercept = 0) +
      geom_line(data = y14, mapping = aes(x = xdate, y = dslowTP / 15, colour = pc))

    temp <- filter(adata, TP > 0.4)
    if (nrow(temp) > 0) {
      p4 <- p4 + # add labelled outliers
        geom_point(data = temp, mapping = aes(x = xdate, y = 0.37)) +
        geom_text(data = temp, mapping = aes(x = xdate, y = 0.37, label = as.character(TP)), nudge_x = 200)
      # p4r2 <- p4r2 + # add labelled outliers
      #   geom_point(data=temp, mapping=aes(x=TPmed, y=0.39), shape = 2)
      # geom_text(data=temp, mapping=aes(x=TPmed, y=0.37, label=as.character(TP)), nudge_y=0.01)
    }

    # testing
    # print(p4)

    #### trend analysis ####
    res4 <- y4 %>%
      filter(pc == "50%") %>%
      rename(TPmodel = TP) %>%
      left_join(adata, by = c("x", "xdate")) %>%
      drop_na() %>%
      mutate(TPres = TP - TPmodel) %>%
      mutate(
        xdate2 = decimal_date(xdate),
        month = month(xdate)
      )
    ggplot() +
      geom_point(data = res4, mapping = aes(x = xdate, y = TPres))
    if (sum(!is.na(res4$TP)) > 35) {
      res4fit <- rkt(date = res4$xdate2, y = res4$TPres, block = res4$month, correct = TRUE)
      print(paste("TPres trend = ", res4fit$B / median(res4$TP, na.rm = TRUE), "p = ", res4fit$sl))
    } else if (sum(!is.na(res4$TP)) > 0) {
      res4fit <- rkt(date = res4$xdate2, y = res4$TPres)
      print(paste("TPres trend = ", res4fit$B / median(res4$TP, na.rm = TRUE), "p = ", res4fit$sl))
    } else {
      print("Not enough data for TP trend")
    }

    p5 <- ggplot() +
      labs(title = "", y = "TN " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = TNbreaks) +
      coord_cartesian(ylim = TNlimits) +
      geom_ribbon(data = y5s, mapping = aes(x = xdate, ymin = TNmin - 0.2 * tci, ymax = TNmax + 0.2 * tci), colour = "lightgrey", fill = "lightgrey") +
      # geom_ribbon(data=y5s, mapping=aes(x=xdate, ymin=TNmin, ymax=TNmax), colour=tncol[1], fill=tncol[1]) +
      # geom_ribbon(data=y5s, mapping=aes(x=xdate, ymin=`25%`, ymax=`75%`), colour=tncol[2], fill=tncol[2]) +
      # geom_line(data=y5s, mapping=aes(x=xdate, y=TNmed), colour=tncol[3]) +
      geom_line(data = y5, mapping = aes(x = xdate, y = TN, colour = pc)) +
      geom_point(data = adata, mapping = aes(x = xdate, y = TN))

    # y5s <- y5s %>%
    #   filter(xdate >= dmy("01012005"))

    p5r <- ggplot() +
      labs(title = "", y = "TN residual " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      geom_ribbon(data = y5s, mapping = aes(x = xdate, ymin = TNmin - TNmed - 0.2 * tci, ymax = TNmax - TNmed + 0.2 * tci), colour = "lightgrey", fill = "lightgrey") +
      geom_ribbon(data = y5s, mapping = aes(x = xdate, ymin = TNmin - TNmed, ymax = TNmax - TNmed), colour = tncol[1], fill = tncol[1]) +
      geom_ribbon(data = y5s, mapping = aes(x = xdate, ymin = `25%` - TNmed, ymax = `75%` - TNmed), colour = tncol[2], fill = tncol[2]) +
      geom_line(data = y5s, mapping = aes(x = xdate, y = 0), colour = tncol[3]) +
      geom_point(data = adata, mapping = aes(x = xdate, y = TNr))

    p5r2 <- ggplot() +
      labs(title = "", y = "TN " ~ (mg ~ L^{-1}), x = "Model Median TN " ~ (mg ~ L^{-1}), colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      # scale_x_date(limits=daterange, date_labels='%Y', date_breaks='1 year') +
      # scale_y_continuous(expand=c(0, 0), breaks=TNbreaks) +
      # coord_cartesian(ylim=TNlimits) +
      geom_ribbon(data = y5s, mapping = aes(x = TNmed, ymin = TNmin - 0.2 * tci, ymax = TNmax + 0.2 * tci), colour = "lightgrey", fill = "lightgrey") +
      geom_ribbon(data = y5s, mapping = aes(x = TNmed, ymin = TNmin, ymax = TNmax), colour = tncol[1], fill = tncol[1]) +
      geom_ribbon(data = y5s, mapping = aes(x = TNmed, ymin = `25%`, ymax = `75%`), colour = tncol[2], fill = tncol[2]) +
      geom_line(data = y5s, mapping = aes(x = TNmed, y = TNmed), colour = tncol[3]) +
      # geom_smooth(data=adata, mapping=aes(x=TNmed, y=TN), linetype=2, colour="black", method="loess") +
      geom_point(data = adata, mapping = aes(x = TNmed, y = TN))

    p5r3 <- ggplot() +
      labs(title = "", y = "TN " ~ (mg ~ L^{-1}), x = "Flow " ~ (m^3 ~ s^{-1}), colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      # scale_x_date(limits=daterange, date_labels='%Y', date_breaks='1 year') +
      # scale_x_log10() +
      scale_x_continuous(limits = range(adata$TF), breaks = flow_breaks(adata$TF)) +
      # scale_x_continuous(limits = range(adata$TF[!is.na(adata$TN)])) +
      coord_trans(x = "flow") +
      # scale_y_continuous(expand=c(0, 0), breaks=TNbreaks) +
      # coord_cartesian(ylim=TNlimits) +
      geom_ribbon(data = y5s, mapping = aes(x = TF, ymin = TNmin - 0.2 * tci, ymax = TNmax + 0.2 * tci), colour = "lightgrey", fill = "lightgrey") +
      geom_ribbon(data = y5s, mapping = aes(x = TF, ymin = TNmin, ymax = TNmax), colour = tncol[1], fill = tncol[1]) +
      geom_ribbon(data = y5s, mapping = aes(x = TF, ymin = `25%`, ymax = `75%`), colour = tncol[2], fill = tncol[2]) +
      geom_line(data = y5s, mapping = aes(x = TF, y = TNmed), colour = tncol[3]) +
      # geom_smooth(data=adata, mapping=aes(x=TF, y=TN), linetype=2, colour="black", method="loess") +
      geom_point(data = adata, mapping = aes(x = TF, y = TN))

    p5r4 <- ggplot() +
      labs(title = "", y = "TN residual " ~ (mg ~ L^{-1}), x = "Flow " ~ (m^3 ~ s^{-1}), colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      # scale_x_date(limits=daterange, date_labels='%Y', date_breaks='1 year') +
      # scale_x_log10() +
      scale_x_continuous(limits = range(adata$TF), breaks = flow_breaks(adata$TF)) +
      # scale_x_continuous(limits = range(adata$TF[!is.na(adata$TN)])) +
      coord_trans(x = "flow") +
      # scale_y_continuous(expand=c(0, 0), breaks=TNbreaks) +
      # coord_cartesian(ylim=TNlimits) +
      geom_ribbon(data = y5s, mapping = aes(x = TF, ymin = TNmin - TNmed - 0.2 * tci, ymax = TNmax - TNmed + 0.2 * tci), colour = "lightgrey", fill = "lightgrey") +
      geom_ribbon(data = y5s, mapping = aes(x = TF, ymin = TNmin - TNmed, ymax = TNmax - TNmed), colour = tncol[1], fill = tncol[1]) +
      geom_ribbon(data = y5s, mapping = aes(x = TF, ymin = `25%` - TNmed, ymax = `75%` - TNmed), colour = tncol[2], fill = tncol[2]) +
      geom_line(data = y5s, mapping = aes(x = TF, y = TNmed - TNmed), colour = tncol[3]) +
      # geom_smooth(data=adata, mapping=aes(x=TF, y=TN), linetype=2, colour="black", method="loess") +
      geom_point(data = adata, mapping = aes(x = TF, y = TN - TNmed))

    p9 <- ggplot() +
      labs(title = "", y = "fTN " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = TNbreaks) +
      coord_cartesian(ylim = TNlimits) +
      geom_point(data = old_box, mapping = aes(x = xdate, y = chem2fast), shape = 1) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = low), colour = wrtdscol, linetype = 2) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = med), colour = wrtdscol, linetype = 5) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = high), colour = wrtdscol, linetype = 6) +
      geom_line(data = y9, mapping = aes(x = xdate, y = fastTN, colour = pc))
    p15 <- ggplot() +
      labs(title = "", y = "dfTN ", x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = dTNbreaks) +
      coord_cartesian(ylim = dTNlimits) +
      geom_hline(yintercept = 0) +
      geom_line(data = y15, mapping = aes(x = xdate, y = dfastTN / 15, colour = pc))

    p10 <- ggplot() +
      labs(title = "", y = "mTN " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = TNbreaks) +
      coord_cartesian(ylim = TNlimits) +
      geom_point(data = old_box, mapping = aes(x = xdate, y = chem2med), shape = 1) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = low), colour = wrtdscol, linetype = 2) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = med), colour = wrtdscol, linetype = 5) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = high), colour = wrtdscol, linetype = 6) +
      geom_line(data = y10, mapping = aes(x = xdate, y = medTN, colour = pc))
    p16 <- ggplot() +
      labs(title = "", y = "dmTN ", x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = dTNbreaks) +
      coord_cartesian(ylim = dTNlimits) +
      geom_hline(yintercept = 0) +
      geom_line(data = y16, mapping = aes(x = xdate, y = dmedTN / 15, colour = pc))

    p11 <- ggplot() +
      labs(title = "", y = "sTN " ~ (mg ~ L^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = TNbreaks) +
      coord_cartesian(ylim = TNlimits) +
      geom_point(data = old_box, mapping = aes(x = xdate, y = chem2slow), shape = 1) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = low), colour = wrtdscol, linetype = 2) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = med), colour = wrtdscol, linetype = 5) +
      geom_line(data = wrtds[["TN"]], mapping = aes(x = date, y = high), colour = wrtdscol, linetype = 6) +
      geom_line(data = y11, mapping = aes(x = xdate, y = slowTN, colour = pc))
    p17 <- ggplot() +
      labs(title = "", y = "dsTN ", x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = tncol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = dTNbreaks) +
      coord_cartesian(ylim = dTNlimits) +
      geom_hline(yintercept = 0) +
      geom_line(data = y17, mapping = aes(x = xdate, y = dslowTN / 15, colour = pc))

    res5 <- y5 %>%
      filter(pc == "50%") %>%
      rename(TNmodel = TN) %>%
      left_join(adata, by = c("x", "xdate")) %>%
      drop_na() %>%
      mutate(TNres = TN - TNmodel) %>%
      mutate(
        xdate2 = decimal_date(xdate),
        month = month(xdate)
      )
    ggplot() +
      geom_point(data = res5, mapping = aes(x = xdate, y = TNres))
    if (sum(!is.na(res4$TN)) > 35) {
      res5fit <- rkt(date = res5$xdate2, y = res5$TNres, block = res5$month, correct = TRUE)
      print(paste("TNres trend = ", res5fit$B / median(res5$TN, na.rm = TRUE), "p = ", res5fit$sl))
    } else if (sum(!is.na(res4$TN)) > 0) {
      res5fit <- rkt(date = res5$xdate2, y = res5$TNres)
      print(paste("TNres trend = ", res5fit$B / median(res5$TN, na.rm = TRUE), "p = ", res5fit$sl))
    } else {
      print("Not enough data for TN trend")
    }

    # fit plot
    # plotchem <- plot_grid(p4, p5, p0, nrow=3, align="v")
    # print(plotchem)
    # file_name <- paste(out_path, setname, '_chemtrace.png', sep="")
    # save_plot(file_name, plotchem, base_height=7, base_width=8)

    #### plot flow trace ####
    p1 <- ggplot() +
      labs(title = "", y = "Fast " ~ (m^3 ~ s^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = fcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = flowbreaks) +
      coord_cartesian(ylim = flowlimits) +
      geom_line(data = y1, mapping = aes(x = xdate, y = Fast, colour = pc))

    p2 <- ggplot() +
      labs(title = "", y = "Med. " ~ (m^3 ~ s^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = mcol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = flowbreaks) +
      coord_cartesian(ylim = flowlimits) +
      geom_line(data = y2, mapping = aes(x = xdate, y = Medium, colour = pc))

    p3 <- ggplot() +
      labs(title = "", y = "Slow " ~ (m^3 ~ s^{-1}), x = "", colour = "Percentile") +
      theme_cowplot() +
      theme(legend.position = "none", plot.margin = unit(c(0, 0.3, 0, 0), "cm"), plot.title = element_blank()) +
      panel_border(colour = "black") +
      scale_colour_manual(values = scol[sort]) +
      scale_x_date(limits = daterange, date_labels = "%Y", date_breaks = "1 year") +
      scale_y_continuous(expand = c(0, 0), breaks = flowbreaks) +
      coord_cartesian(ylim = flowlimits) +
      geom_line(data = y3, mapping = aes(x = xdate, y = Slow, colour = pc))

    y6$Slow <- filter(y3, pc == "50%")$Slow
    y6$Medium <- filter(y2, pc == "50%")$Medium
    aah <- aah +
      geom_line(data = y6, mapping = aes(x = xdate, y = Medium + Slow), colour = "deepskyblue") + # add bach results
      geom_line(data = y6, mapping = aes(x = xdate, y = Slow), colour = "orchid") + # add bach results
      annotate(geom = "label", x = min(y6$xdate) + 120, y = max(TFlimits) * 0.8, label = setname, size = 4) # rewrite label

    # plotflow <- plot_grid(p1, p2, p3, nrow=3, align="v")
    # print(plotflow)
    # file_name <- paste(out_path, setname, '_flowtrace.png', sep="")
    # save_plot(file_name, plotflow, base_height=7, base_width=8)

    # p1 <- ggplot() +
    #   labs(title='', y='Fast '~(m^3~s^{-1}), x='', colour='Percentile') +
    #   theme_cowplot() +
    #   theme(legend.position='none', plot.margin=unit(c(0, 0.3, 0, 0), 'cm'), plot.title=element_blank()) +
    #   panel_border(colour='black') +
    #   scale_colour_manual(values=c('orange','firebrick','darkred','firebrick','orange')) +
    #   scale_x_date(limits=daterange, date_labels='%Y', date_breaks='1 year') +
    #   scale_y_continuous(expand = c(0, 0), breaks=seq(0,10,2)) +
    #   coord_cartesian(ylim=c(0, 10)) +
    #   geom_line(data=y1, mapping=aes(x=xdate, y=Fast, colour=pc))

    title <- ggdraw() + draw_label(catchname, fontface = "bold")
    plotall <- plot_grid(title, p4, p5, p0, p1, p2, p3, ncol = 1, rel_heights = c(0.3, 1, 1, 1, 1, 1, 1), align = "v")
    # print(plotall)
    file_name <- paste(out_path, setname, "_alltrace.png", sep = "")
    save_plot(file_name, plotall, base_height = 10, base_width = 8)

    title <- ggdraw() + draw_label(catchname, fontface = "bold")
    plotall <- plot_grid(title, p4r, p5r, ncol = 1, rel_heights = c(0.3, 1, 1), align = "v")
    # print(plotall)
    file_name <- paste(out_path, setname, "_residtime.png", sep = "")
    save_plot(file_name, plotall, base_height = 5, base_width = 8)

    title <- ggdraw() + draw_label(catchname, fontface = "bold")
    blank <- ggdraw()
    plotall <- plot_grid(title, blank, p4r2, p5r2, ncol = 2, rel_heights = c(0.1, 1), align = "v")
    # print(plotall)
    file_name <- paste(out_path, setname, "_residmedian.png", sep = "")
    save_plot(file_name, plotall, base_height = 5, base_width = 8)

    title <- ggdraw() + draw_label(catchname, fontface = "bold")
    blank <- ggdraw()
    plotall <- plot_grid(title, blank, p4r3, p5r3, ncol = 2, rel_heights = c(0.1, 1), align = "v")
    # print(plotall)
    file_name <- paste(out_path, setname, "_concflow.png", sep = "")
    save_plot(file_name, plotall, base_height = 5, base_width = 8)

    title <- ggdraw() + draw_label(catchname, fontface = "bold")
    blank <- ggdraw()
    plotall <- plot_grid(title, blank, p4r4, p5r4, ncol = 2, rel_heights = c(0.1, 1), align = "v")
    # print(plotall)
    file_name <- paste(out_path, setname, "_residflow.png", sep = "")
    save_plot(file_name, plotall, base_height = 5, base_width = 8)

    title <- ggdraw() + draw_label(catchname, fontface = "bold")
    plotall <- plot_grid(title, p6, p7, p8, p9, p10, p11, ncol = 1, rel_heights = c(0.3, 1, 1, 1, 1, 1, 1), align = "v")
    # print(plotall)
    file_name <- paste(out_path, setname, "_conctrace.png", sep = "")
    save_plot(file_name, plotall, base_height = 10, base_width = 8)

    title <- ggdraw() + draw_label(catchname, fontface = "bold")
    plotall <- plot_grid(title, p12, p13, p14, p15, p16, p17, ncol = 1, rel_heights = c(0.3, 1, 1, 1, 1, 1, 1), align = "v")
    # print(plotall)
    file_name <- paste(out_path, setname, "_dconctrace.png", sep = "")
    save_plot(file_name, plotall, base_height = 10, base_width = 8)

    # some useful information
    print(paste("Mean flow calib =", meanTFcalib))
    print(paste("Min fast flow =", min(y1$Fast)))
    print(paste("Max fast flow =", max(y1$Fast)))
    print(paste("Min medium flow =", min(y2$Medium)))
    print(paste("Max medium flow =", max(y2$Medium)))
    print(paste("Min slow flow =", min(y3$Slow)))
    print(paste("Max slow flow =", max(y3$Slow)))
  } # end if file exists

  ah[[aalloptions$setseq]] <- aah # store hydrograph
} # end for loop

#### plot all hydrographs ####
if (nruns == 24) {
  blank <- ggplot(data.frame()) + geom_point()
  plotah <- plot_grid(
    blank, blank, blank,
    ah[[1]], ah[[2]], ah[[3]],
    ah[[4]], ah[[5]], ah[[6]],
    ah[[7]], ah[[8]], ah[[9]],
    ah[[10]], ah[[11]], ah[[12]],
    ah[[13]], ah[[14]], ah[[15]],
    ah[[16]], ah[[17]], ah[[18]],
    ah[[19]], ah[[20]], ah[[21]],
    ah[[22]], ah[[23]], ah[[24]],
    rel_heights = c(0.2, 1, 1, 1, 1, 1, 1, 1, 1), ncol = 3, align = "v"
  )
  # print(plotah)
  file_name <- paste(out_path, "all_hydrotrace.png", sep = "")
  save_plot(file_name, plotah, base_height = 12, base_width = 12)
} else if (nruns == 8) {
  blank <- ggplot(data.frame()) + geom_point()
  plotah <- plot_grid(
    blank,
    ah[[1]], ah[[2]], ah[[3]],
    ah[[4]], ah[[5]], ah[[6]],
    ah[[7]], ah[[8]],
    rel_heights = c(0.2, 1, 1, 1, 1, 1, 1, 1, 1), ncol = 1, align = "v"
  )
  # print(plotah)
  file_name <- paste(out_path, "all_hydrotrace.png", sep = "")
  save_plot(file_name, plotah, base_height = 12, base_width = 12)
}


# R script to download selected samples
# Copy code and run on a local machine to initiate download

library("rhdf5")    # can be installed using Bioconductor

destination_file = "selected_species_matrix_v10.h5"
extracted_expression_file = "searchterm_expression_matrix.tsv"
url = "https://s3.amazonaws.com/mssm-seq-matrix/selected_species_matrix_v10.h5"

# Check if gene expression file was already downloaded, if not in current directory download file form repository
if(!file.exists(destination_file)){
    print("Downloading compressed gene expression matrix.")
    download.file(url, destination_file, quiet = FALSE, mode = 'wb')
}

# Selected samples to be extracted
samp = c(insert_samples)

# Retrieve information from compressed data
samples = h5read(destination_file, "meta/samples/geo_accession")
genes = h5read(destination_file, "meta/genes/genes")

# Identify columns to be extracted
sample_locations = which(samples %in% samp)

# extract gene expression from compressed data
expression = t(h5read(destination_file, "data/expression", index=list(sample_locations, 1:length(genes))))
H5close()
rownames(expression) = genes
colnames(expression) = samples[sample_locations]

# Print file
write.table(expression, file=extracted_expression_file, sep="\t", quote=FALSE, col.names=NA)
print(paste0("Expression file was created at ", getwd(), "/", extracted_expression_file))