#' graficarSegmento
#' Grafica un segmento dado 2 puntos
#'
#' @param a vector
#' @param b vector
#'
#' @return vector
#'
#' @export
#'
#' @examples
#' graficarSegmento(c(1,1),c(2,2))
graficarSegmento <- function(a,b){
  puntosx <- c(a[1],b[1])
  puntosy <- c(a[2],b[2])

  plot(x = puntosx,
       y = puntosy,
       col = "red",
       lwd = 4
       )

  segments(a[1],a[2],b[1],b[2],col = "blue", lwd = 3)

}


#' @export
#' @title dataOverlap
#' @description compare 2 datasets and returns values that overlap
#' @param \code{data1} dataset #1
#' @param \code{data2} dataset #2
#' @param \code{distance.Theshold} defaults to 0.1
#' @param \code{dnames} defaults to \code{c("EID","X","Y","date","salinity","temperature","depth","source")}
#' @return \code{Data}
#' @author unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @family overly specific
#' @note should not the return object should probably be Data1, not Data?
#' @export
dataOverlap<-function(data1,data2,distance.Theshold=0.1,dnames=c("EID","X","Y","date","salinity","temperature","depth","source")){

	data1$EID<-1:nrow(data1)
	data2$EID<-(1:nrow(data2))+nrow(data1)

	data1$source<-1
	data2$source<-2

	days<-sort(unique(data1$date))

	Add.lst<-list()
	Reject.lst<-list()

	for(i in 1:length(days)){

		x<-subset(data1,date==days[i],dnames)
		y<-subset(data2,date==days[i],dnames)
		z<-rbind(x,y)
		z$Overlap<-NA
		attr(z,'projection')<-"LL"
		z<-convUL(z)
		W<-owin(range(z$X),range(z$Y))
		ppp<-as.ppp(subset(z,select=c('X','Y')),W)
		z$nndist<-nndist(ppp)
		z<-convUL(z)
		z$Overlap[z$nndist>=distance.Theshold]<-F
		z$Overlap[z$nndist<distance.Theshold]<-T
		Add.lst[[i]]<-subset(z,source==1)
		}

	Data1<-do.call("rbind",Add.lst)
	return(Data)
}


REBOL [
    System: "REBOL [R3] Language Interpreter and Run-time Environment"
    Title: "Generic function interface definitions"
    Rights: {
        Copyright 2012 REBOL Technologies
        Copyright 2012-2018 Ren-C Open Source Contributors
        REBOL is a trademark of REBOL Technologies
    }
    License: {
        Licensed under the Apache License, Version 2.0.
        See: http://www.apache.org/licenses/LICENSE-2.0
    }
    Description: {
        The sense of the term "generic" used here is that of a function which
        has no default implementation--rather each data type supplies its own
        implementation.  The code that runs is based on the argument types:

        https://en.wikipedia.org/wiki/Generic_function
        http://factor-language.blogspot.com/2007/08/mixins.html

        At the moment, only the first argument's type is looked at to choose
        the the dispatch.  This is how common verbs like APPEND or ADD are
        currently implemented.

        !!! The dispatch model in Rebol, and how it might be extended beyond
        the list here (to either more generics, or to user-defined datatypes)
        was not fleshed out, and needs to get attention at some point.
    }
    Notes: {
        Historical Rebol called generics "ACTION!"--a term that has been
        retaken for the "one function datatype":

        https://forum.rebol.info/t/596

        This file is executed during the boot process, after collecting its
        top-level SET-WORD! and binding them into the LIB context.  GENERIC
        is an action which quotes its left-hand side--it does this so that
        it knows the symbol that it is being assigned to.  That symbol is
        what is passed in to the "type dispatcher", so each datatype can
        have its own implementation of the generic function.

        The build process scans this file for the SET-WORD!s also, in order
        to add SYM_XXX constants to the word list--so that switch() statements
        in C can be used during dispatch.
    }
]

; Binary Math & Logic

add: generic [
    {Returns the addition of two values.}
    return: [char! any-scalar! date! binary!]
    value1 [char! any-scalar! date! binary!]
    value2 [char! any-scalar! date!]
]

subtract: generic [
    {Returns the second value subtracted from the first.}
    return: [char! any-scalar! date! binary!]
    value1 [char! any-scalar! date! binary!]
    value2 [char! any-scalar! date!]
]

multiply: generic [
    {Returns the first value multiplied by the second.}
    return: [char! any-scalar!]
    value1 [char! any-scalar!]
    value2 [char! any-scalar!]
]

divide: generic [
    {Returns the first value divided by the second.}
    return: [char! any-scalar!]
    value1 [char! any-scalar!]
    value2 [char! any-scalar!]
]

remainder: generic [
    {Returns the remainder of first value divided by second.}
    return: [char! any-scalar!]
    value1 [char! any-scalar!]
    value2 [char! any-scalar!]
]

power: generic [
    {Returns the first number raised to the second number.}
    return: [any-number!]
    number [any-number!]
    exponent [any-number!]
]

bitwise-and: generic [
    {Bitwise AND of two values}
    return: [logic! integer! char! tuple! binary!]
    value1 [logic! integer! char! tuple! binary!]
    value2 [logic! integer! char! tuple! binary!]
]

bitwise-or: generic [
    {Bitwise OR of two values}
    return: [logic! integer! char! tuple! binary!]
    value1 [logic! integer! char! tuple! binary!]
    value2 [logic! integer! char! tuple! binary!]
]

bitwise-xor: generic [
    {Bitwise XOR of two values}
    return: [logic! integer! char! tuple! binary!]
    value1 [logic! integer! char! tuple! binary!]
    value2 [logic! integer! char! tuple! binary!]
]

bitwise-and-not: generic [
    {Bitwise AND NOT of two values}
    return: [logic! integer! char! tuple! binary!]
    value1 [logic! integer! char! tuple! binary!]
    value2 [logic! integer! char! tuple! binary!]
]

intersect: generic [
    {Returns the intersection (AND) of two sets}

    return: [
        logic! integer! char! tuple!  ; math
        any-array! any-string! bitset! typeset!  ; sets
        binary!  ; ???
    ]
    value1 [
        logic! integer! char! tuple!  ; math
        any-array! any-string! bitset! typeset!  ; sets
        binary!  ; ???
    ]
    value2 [
        logic! integer! char! tuple!  ; math
        any-array! any-string! bitset! typeset!  ; sets
        binary!  ; ???
    ]
    /case "Uses case-sensitive comparison"
    /skip "Treat the series as records of fixed size"
        [integer!]
]

union: generic [
    {Returns the union (OR) of two sets}

    return: [
        logic! integer! char! tuple!  ; math
        any-array! any-string! bitset! typeset!  ; sets
        binary!  ; ???
    ]
    value1 [
        logic! integer! char! tuple!  ; math
        any-array! any-string! bitset! typeset!  ; sets
        binary!  ; ???
    ]
    value2 [
        logic! integer! char! tuple!  ; math
        any-array! any-string! bitset! typeset!  ; sets
        binary!  ; ???
    ]
    /case "Use case-sensitive comparison"
    /skip "Treat the series as records of fixed size"
        [integer!]
]

difference: generic [
    {Returns the special difference (XOR) of two sets}

    return: [
        logic! integer! char! tuple!
        any-array! any-string! bitset! typeset!
        binary!
        time!  ; !!! Under review, this really doesn't fit
    ]
    value1 [
        logic! integer! char! tuple!  ; math
        any-array! any-string! bitset! typeset!  ; sets
        binary!  ; ???
        date!  ; !!! Under review, this really doesn't fit
    ]
    value2 [
        logic! integer! char! tuple!  ; math
        any-array! any-string! bitset! typeset!  ; sets
        binary!  ; ???
        date!  ; !!! Under review, this really doesn't fit
    ]
    /case "Uses case-sensitive comparison"
    /skip "Treat the series as records of fixed size"
        [integer!]
]

exclude: generic [
    {Returns the first data set less the second data set.}

    return: [any-array! any-string! binary! bitset! typeset!]
    data "original data"
        [any-array! any-string! binary! bitset! typeset!]
    exclusions "data to exclude from series"
        [any-array! any-string! binary! bitset! typeset!]
    /case "Uses case-sensitive comparison"
    /skip "Treat the series as records of fixed size"
        [integer!]
]

; Unary

negate: generic [
    {Changes the sign of a number (see COMPLEMENT for inversion of sets)}
    return: [any-number! pair! money! time!]
    number [any-number! pair! money! time!]
]

bitwise-not: generic [
    {Returns the one's complement value.}
    return: [logic! integer! tuple! binary!]
    value [logic! integer! tuple! binary!]
]

complement: generic [
    {Returns the inversion of a set}
    return: [bitset! typeset!]
    value [bitset! typeset!]
]

unique: generic [
    {Returns the data set with duplicates removed}

    return: [any-array! any-string! binary! bitset! typeset!]
    series [any-array! any-string! binary! bitset! typeset!]
    .dummy  ; unused, makes frame-compatible with INTERSECT/UNIQUE/etc.
    /case "Use case-sensitive comparison (except bitsets)"
    /skip "Treat the series as records of fixed size"
        [integer!]
]

absolute: generic [
    {Returns the absolute value.}
    return: [any-number! pair! money! time!]
    value [any-number! pair! money! time!]
]

round: generic [
    {Rounds a numeric value; halves round up (away from zero) by default}

    return: [any-number! pair! money! time!]
    value "The value to round"
        [any-number! pair! money! time!]
    /to "Return the nearest multiple of the parameter (must be non-zero)"
        [any-number! money! time!]
    /even "Halves round toward even results"
    /down "Round toward zero, ignoring discarded digits. (truncate)"
    /half-down "Halves round toward zero"
    /floor "Round in negative direction"
    /ceiling "Round in positive direction"
    /half-ceiling "Halves round in positive direction"
]

random: generic [
    {Returns a random value of the same datatype; or shuffles series.}
    return: [<opt> any-value!]
    value   {Maximum value of result (modified when series)}
    /seed   {Restart or randomize}
    /secure {Returns a cryptographically secure random number}
    /only   {Pick a random value from a series}
]

odd?: generic [
    {Returns TRUE if the number is odd.}
    return: [logic!]
    number [any-number! char! date! money! time! pair!]
]

even?: generic [
    {Returns TRUE if the number is even.}
    return: [logic!]
    number [any-number! char! date! money! time! pair!]
]

; Series Navigation

skip: generic [
    {Returns the series forward or backward from the current position.}
    return: "Input skipped by offset, or null if out of bounds"
        [<opt> any-series! port!]
    series [<blank> any-series! port!]
    offset [any-number! logic! pair!]
    /unbounded "Return out of bounds series if before tail or after head"
]

at: generic [
    {Returns the series at the specified index.}
    return: "Input at the given index, not clipped to head/tail by default"
        [<opt> any-series! port!]
    series [<blank> any-series! port!]
    index [any-number! logic! pair!]
    /bounded "Return null if index is before tail or after head"
]

; Series Search

find: generic [
    {Searches for the position where a matching value is found}

    return: "position found, else null - logic true if non-positional find"
        [<opt> any-series! logic!]
    series [
        <blank> any-series! any-context! map! bitset! typeset!
    ]
    pattern [<blank> any-value!]
    /part "Limits the search to a given length or position"
        [any-number! any-series! pair!]
    /case "Characters are case-sensitive"
    /skip "Treat the series as records of fixed size"
        [integer!]
    /tail "Returns the end of the series"
    /match "Performs comparison and returns the tail of the match"
    /reverse "Deprecated: https://forum.rebol.info/t/1126"
    /last "Deprecated: https://forum.rebol.info/t/1126"
]

select: generic [
    {Searches for a value; returns the value that follows, else null}

    return: [<opt> any-value!]
    series [<blank> any-series! any-context! map!]
    value [any-value!]
    /part "Limits the search to a given length or position"
        [any-number! any-series! pair!]
    /case "Characters are case-sensitive"
    /skip "Treat the series as records of fixed size"
        [integer!]
    /tail  ; for frame compatibility with FIND
    /match  ; for frame compatibility with FIND
    /reverse "Deprecated: https://forum.rebol.info/t/1126"
    /last "Deprecated: https://forum.rebol.info/t/1126"
]

pick-poke*: generic [
    {Low-level hook for PICK and POKE, used also by PATH! and SET-PATH!}

    return: "PICK: the retrieved value, POKE: bits parent cell must update"
        [<opt> any-value!]
    location "Target value (on some steps, bits are modified if POKE)"
        [any-value!]
    steps "A pre-COMPOSE'd list of steps in the PICK or POKE chain"
        [block!]
    ^value "Value to POKE via ^META protocol (true NULL signals a PICK)"
        [<opt> any-value!]
]

; !!! PUT was added by Red as the complement to SELECT, which offers a /CASE
; refinement for adding keys to MAP!s case-sensitively.  The name may not
; be ideal, but it's something you can't do with path access, so adopting it
; for the time-being.  Only implemented for MAP!s at the moment
;
put: generic [
    {Replaces the value following a key, and returns the new value.}
    return: [<opt> any-value!]
    series [map!]
    key [any-value!]
    value [<opt> any-value!]
    /case {Perform a case-sensitive search}
]

; Making, copying, modifying

copy: generic [
    {Copies a series, object, or other value.}

    return: "Return type will match the input type, or void if blank"
        [<opt> any-value!]
    value "If an ANY-SERIES!, it is only copied from its current position"
        [any-value!]
    /part "Limits to a given length or position"
        [any-number! any-series! pair!]
    /deep "Also copies series values within the block"
    /types "What datatypes to copy"
        [typeset! datatype!]
]

take: generic [
    {Removes and returns one or more elements}

    return: [<opt> any-value!]
    series "At position (modified)"
        [any-series! port! varargs!]
    /part "Specifies a length or end position"
        [any-number! any-series! pair!]
    /deep "Also copies series values within the block"
    /last "Take it from the tail end"
]

; !!! INSERT, APPEND, CHANGE expect to have compatible frames...same params
; at the same position, with same types!
;
insert: generic [
    {Inserts element(s); for series, returns just past the insert.}

    return: "Just past the insert"
        [any-series! port! map! object! bitset! port!
        integer!]  ; !!! INSERT returns INTEGER! in ODBC, review this
    series "At position (modified)"
        [any-series! port! map! object! bitset! port!]
    value "What to insert (BLANK!s opt out)"
        [any-value!]
    /part "Limits to a given length or position"
        [any-number! any-series! pair!]
    /dup "Duplicates the insert a specified number of times"
        [any-number! pair!]
    /line "Data should be its own line (use as formatting cue if ANY-ARRAY!)"
]

; !!! INSERT, APPEND, CHANGE expect to have compatible frames...same params
; at the same position, with same types!
;
append: generic [
    {Inserts element(s) at tail; for series, returns head.}

    return: [any-series! port! map! object! module! bitset!]
    series "Any position (modified)"
        [any-series! port! map! object! module! bitset!]
    value "What to append (BLANK!s opt out)"
        [any-value!]
    /part "Limits to a given length or position"
        [any-number! any-series! pair!]
    /dup "Duplicates the insert a specified number of times"
        [any-number! pair!]
    /line "Data should be its own line (use as formatting cue if ANY-ARRAY!)"
]

; !!! INSERT, APPEND, CHANGE expect to have compatible frames...same params
; at the same position, with same types!
;
change: generic [
    {Replaces element(s); returns just past the change}

    return: [any-series! port!]
    series "At position (modified)"
        [any-series! port!]
    value "The new value (BLANK!s opt out)"
        [any-value!]
    /part "Limits the amount to change to a given length or position"
        [any-number! any-series! pair!]
    /dup "Duplicates the change a specified number of times"
        [any-number! pair!]
    /line "Data should be its own line (use as formatting cue if ANY-ARRAY!)"
]

remove: generic [
    {Removes element(s); returns same position}

    return: [any-series! map! port! bitset!]
    series "At position (modified)"
        [any-series! map! port! bitset!]
    /part "Removes multiple elements or to a given position"
        [any-number! any-series! pair! char!]
]

clear: generic [
    {Removes elements from current position to tail; returns at new tail}

    return: [any-series! port! map! bitset!]
    series "At position (modified)"
        [any-series! port! map! bitset!]
]

swap: generic [
    {Swaps elements between two series or the same series}

    return: [any-series!]
    series1 [any-series!] {At position (modified)}
    series2 [any-series!] {At position (modified)}
]

reverse: generic [
    {Reverses the order of elements; returns at same position}

    return: [any-series! any-sequence! pair!]
    series "At position (modified)"
        [any-series! any-sequence! pair!]
    /part "Limits to a given length or position"
        [any-number! any-series!]
]

sort: generic [
    {Sorts a series; default sort order is ascending}

    return: [any-series!]
    series "At position (modified)"
        [any-series!]
    /case "Case sensitive sort"
    /skip "Treat the series as records of fixed size"
        [integer!]
    /compare "Comparator offset, block or action"
        [integer! block! action!]
    /part "Sort only part of a series (by length or position)"
        [any-number! any-series!]
    /all "Compare all fields"
    /reverse "Reverse sort order"
]

; Port actions:

create: generic [
    {Send port a create request.}
    return: [port!]
    port [port! file! url! block!]
]

delete: generic [
    {Send port a delete request.}
    return: [port!]
    port [port! file! url! block!]
]

open: generic [
    {Opens a port; makes a new port from a specification if necessary}

    return: [port!]
    spec [port! file! url! block!]
    /new "Create new file - if it exists, reset it (truncate)"
    /read "Open for read access"
    /write "Open for write access"
]

connect: generic [
    {Connects a port (used to be "second open step")}

    return: [port!]
    spec [port!]
]

close: generic [
    {Closes a port/library.}
    return: [<opt> any-value!]
    port [port!]  ; !!! See Extend_Generics_Someday() for why LIBRARY! works
]

read: generic [
    {Read from a file, URL, or other port.}
    return: "null on (some) failures (REVIEW as part of port model review)" [
        <opt> binary!  ; should all READ return a BINARY!?
        text!  ; READ/STRING returned TEXT!
        block!  ; READ/LINES returned BLOCK!
        port!  ; asynchronous READ on PORT!s returned the PORT!
        tuple!  ; READ/DNS returned tuple!
        bad-word!  ; !!! If READ is Ctrl-C'd in nonhaltable API calls, ATM
    ]
    source [port! file! url! block!]
    /part "Partial read a given number of units (source relative)"
        [any-number!]
    /seek "Read from a specific position (source relative)"
        [any-number!]
    /string "Convert UTF and line terminators to standard text string"
    /lines "Convert to block of strings (implies /string)"
]

write: generic [
    {Writes to a file, URL, or port - auto-converts text strings}

    return: [port! block!]  ; !!! http write returns BLOCK!, why?
    destination [port! file! url! block!]
    data "Data to write (non-binary converts to UTF-8)"
        [binary! text! block! object! issue!]
    /part "Partial write a given number of units"
        [any-number!]
    /seek "Write at a specific position"
        [any-number!]
    /append "Write data at end of file"
    /lines "Write each value in a block as a separate line"
]

query: generic [
    {Returns information about a port, file, or URL}

    return: [<opt> object!]
    target [port! file! url! block!]
]

modify: generic [
    {Change mode or control for port or file.}
    return: [logic!]
        "TRUE if successful, FALSE if unsuccessful (!!! REVIEW)"
    target [port! file!]
    field [word! blank!]
    value
]

rename: generic [
    {Rename a file.}
    return: [port! file! url!]
    from [port! file! url! block!]
    to [port! file! url! block!]
]


## Marcel Ramos
## YouTube viewing habits
library(ggplot2)
library(grid)
library(RColorBrewer)
library(xlsx)
library(plyr)

survey <- read.csv("data/PH750-2SurveyData.csv", stringsAsFactors = TRUE)

table(survey$retake)

numberSummaries <- function(number) {
    c(MIN = min(number, na.rm = TRUE),
      MED = median(number, na.rm = TRUE),
      MAX = max(number, na.rm = TRUE))
}

meanSD <- function(number) {
    round(
    c(m = mean(number, na.rm = TRUE),
      sdev  = sd(number, na.rm = TRUE)), 1)
}

###     Subsetting for BIOS students    ###
biosub <- subset(survey, survey$EpiBiosStatus == "Bios")

###     TABLE 1       ###
by(survey$Age, survey$EpiBiosStatus, FUN = meanSD)
# by(survey$Age, survey$EpiBiosStatus, FUN = numberSummaries)

table(survey$Gender, survey$EpiBiosStatus)
round(prop.table(table(survey$Gender, survey$EpiBiosStatus), 2), 2)*100

table(survey$Race2, survey$EpiBiosStatus)
round(prop.table(table(survey$Race2, survey$EpiBiosStatus),2), 2)

by(survey$Travelminutes, survey$EpiBiosStatus, FUN = meanSD)

by(survey$Travelminutes, survey$EpiBiosStatus, FUN = numberSummaries)

# Course Preference by Class

# online for PH752 == Online after class is over
# Add missing category in 2nd Factor

survey$MedPrefEPI2 <- factor(survey$MedPrefEPI2,
                             levels =
                                 c("In person", "Synchronous", "Asynchronous"))
prefs <- cbind(Bios = table(survey$MedPrefBIOS2),
               Epi = table(survey$MedPrefEPI2))
prefs
prop.table(prefs, 2)

fpre <- table(survey$RC1, survey$EpiBiosStatus) + table(survey$RC2, survey$EpiBiosStatus)
fpre/colSums(prefs)

table(survey$retake, survey$EpiBiosStatus)
prop.table(with(survey, xtabs(~retake+EpiBiosStatus)),2)

###     YouTube Viewing Patterns     ###
###             FIGURE 2             ###
### YouTube Lecture Viewing Patterns ###

longdata <- read.csv("data/Figure2YouTubeData.csv", stringsAsFactors = FALSE)
longdata$Day <- as.Date(longdata$Day, format = "%m/%d/%Y")

cols0 <- c("Lecture 2" = "gray85", "Lecture 3" = "gray65",
           "Lecture 4" = "gray45", "Lecture 5" = "gray25")

postscript("Figures/YouTubeViewsF2.eps", width = 8, height = 4,
           paper = "special", horizontal = FALSE, family = "Times")

p <- ggplot(longdata, aes(x = Day, y = views, fill = lecture)) +
    geom_area(position = "stack") + xlab("Date") + ylab("Number of views") +
    labs(fill = "Online Lecture \n Videos") +
    geom_vline(xintercept = as.numeric(as.Date.character("2014-03-03")),
               lty = 4, lwd = 1) +
    geom_line(aes(ymax = views), position = "stack") +
    scale_fill_manual(values = cols0) +
    theme_bw() + theme(plot.background = element_blank(),
                       plot.margin = unit(c(0.5,0,0.5,0), "cm"),
                       panel.grid.major.x = element_blank(),
                       panel.grid.major.y = element_line(size = 0.1, color = "gray"),
                       panel.grid.minor = element_blank(),
                       axis.text.x = element_text(size = 14),
                       axis.text.y = element_text(size = 14),
                       legend.title = element_text(size = 14),
                       legend.text = element_text(size = 14),
                       text = element_text(size = 16))

print(p)

dev.off()

# dev.copy(png, filename = "YTviews.png", width = 960); dev.off()
# dev.copy(pdf, file = "YTviews.pdf", height = 4, width = 8, paper = "special")
# dev.off()

#Totals
table(survey$EpiBiosStatus)

###     FIGURE 1        ###
#Reasons for course pref selection
comb <-  table(biosub$RC1, biosub$MedPrefBIOS2) +
    table(biosub$RC2, biosub$MedPrefBIOS2)
comb <- comb[,c("In person", "Asynchronous", "Synchronous")]
comb <- comb[c("Interactivity", "Convenience",
                    "AvoidCommute", "LearnPref"),]
rownames(comb) <- c("Interactivity", "Convenience", "Avoiding Commute",
                    "Learning Preference")
totals <- matrix(rep(c(12,9,5),4), byrow = TRUE, ncol = 3)
comb/totals

# Figure 1 - encapsulatedpostscript for final graphic

postscript("Figures/FormatPrefF1.eps", width = 6, height = 6,
           paper = "special", horizontal = FALSE, family = "Times")

cols1 <- brewer.pal(4, "Greys")
dens <- seq(10,40, length.out = 4)
barplot(comb, col = cols1, beside = TRUE, legend.text = rownames(comb),
        xlab = "", xaxt = "n", ylab = "", axes = FALSE)
axis(side = 1, labels = colnames(comb), at = c(3,8,13), line = -.75, tick = FALSE)
mtext("Frequency endorsed", side = 2, at = 3.5, line = 2, cex = 1.2)
mtext("Course Format Preferences", side = 1, at = 8, line = 1.5, cex = 1.2)
axis(side = 2, las = 2)

dev.off()

# graphics.off()

###     TABLE 2         ###
# Age by Preference
with(biosub, by(Age, MedPrefBIOS, FUN = meanSD))
with(biosub, by(Age, MedPrefBIOS, FUN = numberSummaries))

with(biosub, kruskal.test(Age~ factor(MedPrefBIOS), data = biosub))
sampAgeMed <- with(biosub, median(Age, na.rm = TRUE))
MedBin1 <- ifelse(biosub$Age>sampAgeMed, "Yes", "No")
fisher.test(table(MedBin1, biosub$MedPrefBIOS))

#Travel Time by Preference
with(biosub, by(Travelminutes, MedPrefBIOS, FUN = meanSD))

with(biosub, by(Travelminutes, MedPrefBIOS, FUN = numberSummaries))

with(biosub, kruskal.test(Travelminutes~ factor(MedPrefBIOS), data = biosub))
sampTMed <- with(biosub, median(Travelminutes, na.rm = TRUE))
MedBin2 <- ifelse(biosub$Travelminutes>sampTMed, "Yes", "No")
fisher.test(table(MedBin2, biosub$MedPrefBIOS))

#Gender by Preference
with(biosub, xtabs(~Gender+MedPrefBIOS))
prop.table(with(biosub, xtabs(~Gender+MedPrefBIOS)),1) #percentages by row
with(biosub, fisher.test(Gender, MedPrefBIOS))

#Race by Preference
with(biosub, fisher.test(Race2, MedPrefBIOS))
with(biosub, xtabs(~Race2+MedPrefBIOS))
prop.table(with(biosub, xtabs(~Race2+MedPrefBIOS)),1) #table with row percentages

#Reasons for Preference with in-group percentages and Fisher p-value
comb
comb/totals
cat("Fisher's Exact test p-value =", fisher.test(comb)$p.value)

#Preference by STEM (ScienceTechnologyEngineeringMathematics) status
with(biosub, xtabs(~STEMstat+MedPrefBIOS))
prop.table(with(biosub, xtabs(~STEMstat+MedPrefBIOS)),1 )

with(biosub, fisher.test(STEMstat,MedPrefBIOS))

#Preference by HybridCourse History
biosub$HybridHist[biosub$HybridHist >= 2] <- 2
biosub$HybridHist <- factor(biosub$HybridHist, levels = c(0, 1, 2),
                            labels = c("Zero", "One", "Two+") )
with(biosub, xtabs(~HybridHist+MedPrefBIOS))
prop.table(with(biosub, xtabs(~ HybridHist + MedPrefBIOS)),1 )
with(biosub, fisher.test(HybridHist, MedPrefBIOS))

#Preference by Responsible for care of children?
with(biosub, xtabs(~CChild+MedPrefBIOS))
prop.table(with(biosub, xtabs(~CChild+MedPrefBIOS)),1 )

with(biosub, fisher.test(CChild,MedPrefBIOS))

#Preference by Confidence Level in Stats
with(biosub, xtabs(~ConfLStatBIOS+MedPrefBIOS))
prop.table(with(biosub, xtabs(~ConfLStatBIOS+MedPrefBIOS)),1 )

with(biosub, fisher.test(ConfLStatBIOS,MedPrefBIOS))

#Preference by Job Status (recoded)
with(biosub, xtabs(~Job+MedPrefBIOS))
prop.table(with(biosub, xtabs(~Job+MedPrefBIOS)),1 )

with(biosub, fisher.test(Job,MedPrefBIOS))

# Preference by Full-time or Part-time student --- Mention
with(biosub, xtabs(~FTPT+MedPrefBIOS))
prop.table(with(biosub, xtabs(~FTPT+MedPrefBIOS)),1 )
with(biosub, fisher.test(FTPT,MedPrefBIOS))

# Work Hours
with(biosub, by(WHours, MedPrefBIOS, FUN = function(x) {c(m = mean(x, na.rm = TRUE), sdev = sd(x, na.rm = TRUE))}))
with(biosub, kruskal.test(WHours~factor(MedPrefBIOS), data = biosub))


# Formatting the 2011 Diallel phenotype data
# Jinliang Yang
# Jan 17th, 2012
# server .7

setwd("/Users/yangjl/Documents/Heterosis_GWAS/pheno2011")

#############################################################
# Check the data completeness and correct the notes
#Notes:
#Dairy 8651-9000 v
#Zumwalt 9251-9600 v
#Johnson J2601-J2950 v
#Ki11: kill@ => Ki11 v
#Ms71: MS71 => Ms71 v

file1 <- read.csv("LL_KRN_test.csv")
dim(file1)
#8678 8

diallel <- subset(file1, Note.y=="Diallel" | Note.y=="NAM Filler");
dim(diallel)
#[1] 2850    8
summary(diallel)

###########################################################
### Delete duplicated input and missing data
# Get ride of 4 duplicated records
dup <- which(duplicated(diallel$Barcode))
diallel <- diallel[!duplicated(diallel$Barcode),]

# Get ride of the missing records
### checking for outlyers
diallel$KRN <- as.numeric(as.character(diallel$KRN));
diallel[is.na(diallel$KRN),]
diallel <- diallel[!is.na(diallel$KRN),]
hist(diallel$KRN, breaks=10)
dim(diallel)
#[1] 2837    8

############################################################
# GCA and SCA
diallel$p1 <- NA;
diallel$p2 <- NA;
diallel$reciprocal <- NA;
diallel$Genotype <- as.character(diallel$Genotype);
for(i in 1:nrow(diallel)){
  tem <- unlist(strsplit(diallel$Genotype[i], split=" x "));
  tem <- sort(tem)
  diallel$p1[i] <- tem[1];
  diallel$p2[i] <- tem[2];
  diallel$reciprocal[i] <- paste(tem[1], tem[2], sep="_")
}

fit <- lm(KRN ~ p1 + p2 + reciprocal, data=diallel)

############# H2 ###############################
fit <- aov(KRN ~ Farm + Genotype, data=diallel)
#7458/(7458+5245+0.7)

#######################################################
### get the LSmean
library(nlme)

# compare the difference of the two models and simple mean
lmeout1 <- lme(KRN~Genotype, data=diallel, random=~1|Farm);
ped.hat1 <- lmeout1$coef$fixed;
ped.hat1[-1] <- ped.hat1[-1]+ped.hat1[1];
names(ped.hat1)[1]="B73 x B97";
names(ped.hat1) <- gsub("Genotype","",names(ped.hat1));
tped <- data.frame(Genotype=names(ped.hat1), KRN=ped.hat1)
dim(tped)
#[1] 315   2
###########################################################
### merge the trait of reciprocal F1
library(ggplot2)

tped$Genotype <- as.character(tped$Genotype);
tped$p1 <- NA;
tped$p2 <- NA;
for (i in 1:nrow(tped)){
  tped$p1[i] <- sort(unlist(strsplit(tped$Genotype[i], split=" x ")))[1];
  tped$p2[i] <- sort(unlist(strsplit(tped$Genotype[i], split=" x ")))[2];
}

tped <- tped[order(tped$p1, tped$p2),]
tped$ped <- paste(tped$p1, tped$p2, sep="|")
lsmean_diallel <- ddply(tped, .(ped), summarise,
            KRN=mean(KRN))
dim(lsmean_diallel)
#[1] 248   2

########################################################
# F1 and parents lsmean:
idx <- grep("@", lsmean_diallel$ped)
lsmean <- lsmean_diallel[-idx,]

plsmean <- lsmean_diallel[idx,]
plsmean$ped <- gsub('@\\|NA',"", plsmean$ped)

########################################################
panzeakrn <- read.csv("panzea_KRN.csv")
panzeakrn$Phenotype.Value <- gsub("mean=", "", panzeakrn$Phenotype.Value)

nam <- read.table("nam_parents", header=TRUE)
p <- c("B73", as.character(nam$parent))

panzeakrn <- subset(panzeakrn, Accession %in% p)
panzeakrn$Phenotype.Value <- as.numeric(panzeakrn$Phenotype.Value);
pkrn <- ddply(panzeakrn, .(Accession), summarise,
              KRN=mean(Phenotype.Value, na.rm=T))
pkrn$Accession <- toupper(pkrn$Accession)
plsmean$ped <- toupper(plsmean$ped)
pkrn <- merge(pkrn, plsmean, by.x="Accession", by.y="ped", all=T)

mymean <- function(x) mean(x, na.rm=T);
pkrn$KRN <- apply(pkrn[,2:3], 1, mymean)
pkrn <- pkrn[, c(1,4)]
names(pkrn)[1] <- "ped"

lsmean <- rbind(lsmean, pkrn)
dim(lsmean)
#[1] 252   2
####################################################
## plot and output lsmean
idx2 <- grep("\\|", lsmean$ped);
f1 <- lsmean[idx2,]
p <- lsmean[-idx2, ]
plot(density(f1$KRN), main="KRN of Diallel and parents", xlim=c(8,21), xlab="KRN", lwd=3, col="blue")
lines(density(p$KRN), lwd=3, lty=2, col="red")

write.table(lsmean, "diallel_lsmean_KRN.csv", sep=",", row.names=FALSE, quote=FALSE)


pdf_file<-"pdf/timeseries_monthly_monthly_labels_2x1_layout.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11,height=11)

layout(matrix(c(1,2),ncol=1),heights=c(80,20))
par(cex=0.75,bg=rgb(240,240,240,maxColorValue=255),omi=c(0.75,0.25,0.5,0.25),mai=c(0.25,0.75,0.25,0),mgp=c(2,1,0),family="Lato Light",las=1)

#  Read data and prepare chart

library(gdata)
myData<-read.xls("mydata/BBK01.WU3140.xlsx")
attach(myData)

myColour1<-rgb(255,0,0,150,maxColorValue=255)
myColour2<-rgb(0,0,0,150,maxColorValue=255)

monthbegin<-seq(as.Date("1988-01-01"),as.Date("2014-01-01"),by="1 months")
yearbegin<-seq(as.Date("1988-01-01"),as.Date("2014-01-01"),by="1 years")

# Create chart and other elements

plot(type="n",axes=F,xlab="",ylab="Index",as.Date(paste(Monat,"01",sep="-")),Wert)
abline(v=yearbegin,col="lightgrey")
points(as.Date(paste(Monat,"01",sep="-")),Wert,col=myColour1,lwd=5,type="l")
axis(1,col=rgb(60,60,60,maxColorValue=255),at=monthbegin,labels=format(monthbegin,"%b\n%Y"),cex.axis=0.95,lwd.ticks=0.1,tck=-0.005)
axis(2,col=rgb(240,240,240,maxColorValue=255),col.ticks=rgb(60,60,60,maxColorValue=255),lwd.ticks=0.5,cex.axis=0.95,tck=-0.01,pos=as.Date("1988-01-01"))
myRate<-rep(0,nrow(myData))
for (i in 2:nrow(myData)) myRate[i]<-(Wert[i]-Wert[i-1])/Wert[i-1]
plot(type="h",axes=F,xlab="",ylab="Growth rate\nprev. month",as.Date(paste(Monat,"01",sep="-")),myRate,col=myColour2,lwd=3)
axis(1,col=rgb(60,60,60,maxColorValue=255),at=monthbegin,labels=format(monthbegin,"%b\n%Y"),cex.axis=0.95,lwd.ticks=0.1,tck=-0.02)
axis(2,col=rgb(240,240,240,maxColorValue=255),col.ticks=rgb(60,60,60,maxColorValue=255),lwd.ticks=0.5,cex.axis=0.95,tck=-0.025,pos=as.Date("1988-01-01"))

# Titling

mtext("DAX Index 1988-2013",3,line=1,adj=0,cex=1.5,family="Lato Black",outer=T)
mtext("Base: Ultimo 1987=1000, End of month",3,line=-1,adj=0,cex=1.25,font=3,outer=T)
mtext("Source: www.bundesbank.de, BBK01.WU3140",1,line=2,adj=1.0,cex=1.05,font=3,outer=T)
dev.off()


# These are parameters to be fed into prep.r and model.r

# Parameters
#############

# Model parameters
model_folder_names <- c("BGY-E0-C4-I8000-A0.8-T12") # fast run

# # Hyperparameters of models where chains could mix
# model_folder_names <-
#   c("BGN-E1-C4-I300000-A0.999-T15",
#     "BGY-E0-C4-I8000-A0.8-T12",
#     "BGY-E1-C4-I300000-A0.999-T15",
#     "FAM-E0-C4-I20000-A0.99-T12")

# # Hyperparameters of models that were "almost there"
# model_folder_names <-
#   c("BGN-E1-C4-I8000-A0.9-T12",
#     "BMY-E0-C4-I8000-A0.95-T12",
#     "BNN-E0-C4-I8000-A0.95-T12",
#     "BNN-E1-C4-I8000-A0.95-T12")

####################################################################################################
####################################################################################################
# model_params        <dataset><ll>-E<te>-C<chains>-I<iter>-A<ad>-T<td>

#     dataset         # BG = biogeographic realms,  GL = global, BM = biomes, LT = latitude-trop/not
#     te              # taxonomic effort 0=no taxonomic effort, 1=publication taxonomic effort
#     ll              # whether using lat lon data (Y) or global.distribution data (N)
#     chains          # stan's number of chains
#     iter            # stan's number of iterations
#     ad              # stan's adapt_delta
#     td              # stan's max tree depth

# note: GL and BM always Y; the rest can be either Y or N
####################################################################################################
####################################################################################################


#------------------------------
# function
#------------------------------

count_num <- function(v){
	rep(length(v), length(v))
}

count_unique <- function(v){
	times <- joint_date[as.integer(names(v))]
	rep(length(unique(times)), length(v))
}

count_up <- function(v){

	if(length(v)==1) return(1)

	times <- joint_date[as.integer(names(v))]
	frank(times, ties.method="dense")
}

count_down <- function(v){

	if(length(v)==1) return(1)

	times <- joint_date[as.integer(names(v))]
	rev(frank(times, ties.method="dense"))
}

selfrank <- function(vec){

	names(vec) <- 1:length(vec)
	duplicated_count(vec, function(v)1:length(v), reset=FALSE)
}

get_selfrank <- function(v){

	if(length(v)==1) return(1)

	times <- joint_date[as.integer(names(v))]

	frank(times, ties.method="dense") %>% selfrank
}

get_response <- function(v, pos){

	if(length(v)==1) return(-1)

	times <- joint_date[as.integer(names(v))]

	if(length(unique(times)) < pos){
		f <- rep(-1, length(v))
		return(f)
	}

	times_rank <- frank(times, ties.method="dense")
	target_responses <- joint_response[names(v[times_rank == pos]) %>% as.integer]

	value <- as.integer(mean(target_responses, na.rm=TRUE) >= 0.5)

	r <- integer(length(v))

	for(i in seq_along(v)){
		if(times_rank[i] != pos){
			r[i] <- value
		}else{
			t <- times_rank == pos
			t[i] <- FALSE
			target_responsesi <- joint_response[names(v[t]) %>% as.integer]
			r[i] <- as.integer(mean(target_responsesi, na.rm=TRUE) >= 0.5)
		}
	}

	r[is.nan(r) | is.na(r)] <- -1
	r
}

keep_name_function <- function(vec, func, ...){

	global_count <<- global_count + 1
	if(global_count %% 100000 == 0) cat("\trow: ", sprintf("%d", global_count), "\n")

	ret <- func(vec, ...)
	names(ret) <- names(vec)
	ret
}

duplicated_count <- function(vec, func, reset=TRUE, ...){

	if(reset) global_count <<- 1

	count <- tapply(vec, vec, keep_name_function, func, simplify = FALSE, ...) %>% unlist
	index <- names(count) %>% strsplit("\\.",) %>% sapply(function(vec)vec[2]) %>% as.integer
	count[order(index)]
}

get_features_duplicated <- function(input){

	names_digest <- names(joint_digest)

	options(stringsAsFactors = FALSE)

	cat("get count_num feature\n")
	d1 <- data.frame(Id=names_digest, count_num=duplicated_count(joint_digest, count_num))
	cat("get count_unique feature\n")
	d2 <- data.frame(Id=names_digest, count_unique=duplicated_count(joint_digest, count_unique))
	cat("get count_up feature\n")
	d3 <- data.frame(Id=names_digest, count_up=duplicated_count(joint_digest, count_up))
	cat("get count_down feature\n")
	d4 <- data.frame(Id=names_digest, count_down=duplicated_count(joint_digest, count_down))

	cat("get selfrank\n")
	sr <- data.frame(Id=names_digest, self_rank=duplicated_count(joint_digest, get_selfrank))
	cat("get response_r1 feature\n")
	r1 <- data.frame(Id=names_digest, response_r1=duplicated_count(joint_digest, get_response, pos=1))
	cat("get response_r2 feature\n")
	r2 <- data.frame(Id=names_digest, response_r2=duplicated_count(joint_digest, get_response, pos=2))
	cat("get response_r3 feature\n")
	r3 <- data.frame(Id=names_digest, response_r3=duplicated_count(joint_digest, get_response, pos=3))

	options(stringsAsFactors = TRUE)

	data.frame(Id=names(input)) %>%
		left_join(d1) %>% left_join(d2) %>% left_join(d3) %>% left_join(d4) %>%
		left_join(sr) %>% left_join(r1) %>% left_join(r2) %>% left_join(r3)
}


#' Plot the prevalence over time
#'
#' @param dat list of counts provided as output from the det model functions
#' @return a plot of the prevalence over time
#'
#' @import ggplot2
#' @import dplyr
#' @importFrom magrittr %>%
#' @importFrom tidyr spread
#' @examples
#' params <- list(ini.prev = 0.001, n.age.cats = 10,  n.e.cats = 6, n.i.cats = 5,
#'               e.move = 0.99, i.move = 0.99, beta = .35, theta = 1,
#'               n0 = 10000, n.days = 360, d.no = 0.05, d.yes = 0.01, beds = 20,
#'               contacts = matrix(1, nrow = 10, ncol = 10),
#'               severity = c(0, 0, 0.001, 0.002, 0.004, 0.010, 0.020, 0.044,
#'               0.093, 0.200))
#'
#' out <- det_model(params)
#' plot_prev_time(out$counts)
#' @export

plot_prev_time <- function(dat){
  if(missing(dat)==TRUE) warning("missing data to plot")

  # summarize by day and disease status, calculate the prevalence
  S <- dat$St %>% group_by(day) %>% summarize(n = sum(n)) %>%
    mutate(category = "S")
  E <- dat$Et %>% group_by(day) %>% summarize(n = sum(n)) %>%
    mutate(category = "E")
  I <- dat$It %>% group_by(day) %>% summarize(n = sum(n)) %>%
    mutate(category = "I")
  R <- dat$Rt %>% group_by(day) %>% summarize(n = sum(n)) %>%
    mutate(category = "R")

  dat.sum <- rbind(S, E, I, R)

  dat.sum <- dat.sum %>%
    spread(key = category, value = n) %>%
    mutate(prev = (I)/ (S + E + I + R))

  ggplot(dat.sum, aes(x = day, y = prev)) +
    geom_line(size = 1.5) +
    ylab("Prevalence") + xlab("Day") +
    theme_light()  + theme(text = element_text(size = 16),
                           panel.grid.minor = element_blank(),
                           panel.grid.major = element_blank())

}


library(tidyverse)
library(parallel)

##
dis5.sum <- mapply(function(indata, tag){
  indata <- peak.sum(indata, groupcol='dis5')
  repcol <- colnames(indata)[grep('r\\d+', colnames(indata), perl=T)]
  print(repcol)
  indata$rpm <- rpm.mean(indata, repcol)
  indata$tag <- tag
  indata[, repcol] <- NULL
  indata <- indata %>% group_by(gene) %>%
    mutate(rpm.nor=rpm/sum(rpm))
  indata <- as.data.frame(indata)
  return(indata)
}, list(disome.data, mono.data), c('disome', 'mono'), SIMPLIFY=F)

## read disome-seq and monosome-seq data ####
disome.peak <- read.table('./disome_peak.txt', header=T, sep='\t', stringsAsFactors=F)
disome.perc <- disome.peak[, c('gene', 'asite', 'read', 'rpm')]
disome.perc <- merge(disome.perc, cds.pep[, c('gene', 'len')], all.x=T, by='gene')
disome.perc$tosc <- disome.perc$asite - (disome.perc$len - 3)
disome.perc$asite.perc <- disome.perc$asite / (disome.perc$len - 3)
disome.perc$sc <- ifelse(disome.perc$asite.perc == 1, 1, 0)
# disome.perc$len <- NULL
disome.perc <- disome.perc %>% group_by(gene) %>%
  mutate(rpm.nor=rpm/sum(rpm)) %>% ungroup() %>%
  as.data.frame()

mono.peak <- read.table('./mono_peak.txt', header=T, sep='\t', stringsAsFactors=F)
mono.perc <- mono.peak[, c('gene', 'asite', 'read', 'rpm')]
mono.perc <- merge(mono.perc, cds.pep[, c('gene', 'len')], all.x=T, by='gene')
mono.perc$tosc <- mono.perc$asite - (mono.perc$len - 3)
mono.perc$asite.perc <- mono.perc$asite / (mono.perc$len - 3)
mono.perc$sc <- ifelse(mono.perc$asite.perc == 1, 1, 0)
mono.perc <- mono.perc %>% group_by(gene) %>%
  mutate(rpm.nor=rpm/sum(rpm)) %>% ungroup() %>%
  as.data.frame()

dis5.sum <- do.call('rbind', dis5.sum)
dis5.sum <- merge(dis5.sum, cds.pep[, c('gene', 'len')], all.x=T, by='gene')
dis5.sum$tosc <- dis5.sum$dis5 - (dis5.sum$len - 3)
dis5.sum$len <- NULL
head(dis5.sum)

plot.dis <- function(indata, inx, iny, low=-Inf, up=Inf, inweight='rpm.nor', indis='tosc') {
  oplot <- ggplot(indata[indata[, indis] >= low & indata[, indis] <= up, ],
                  aes_string(x=indis, weight=inweight, color='tag'))+
    geom_freqpoly(binwidth=1, show.legend=F)+theme_classic()+
    scale_color_manual(values=c("#FF9900", "#3399FF"))+
    # facet_wrap(~tag, scales='free_y', ncol=1, labeller=labeller(tag=c(disome='Disome', mono='Monosome')))+
    facet_wrap(~tag, scales='free_y', ncol=1)+
    geom_text(aes(label=lab), size=3,
              data=data.frame(lab=c('Disome', 'Monosome'),
                              tag=c('disome', 'mono')),
              x=-Inf, y=Inf, hjust=-0.2, vjust=1.2, inherit.aes = F)+
    theme(strip.background=element_blank(),
          strip.text.x=element_blank(),
          axis.title=element_text(size=9),
          axis.text=element_text(size=8),
          axis.line=element_line(size=0.4),
          axis.ticks=element_line(size=0.4))+
    xlab(inx)+
    ylab(iny)
  if (indis == 'tosc'){
    oplot <- oplot+
      geom_vline(xintercept=c(-15, -45, -48, -75, -78),
                 linetype='dashed', color='#66cc00')
  }
  return(oplot)
}

plot.rela.dis <- function(indata1, indata2, intag1, intag2, inweight, iny){
  indata1$inweight <- indata1[, inweight] / (length(unique(indata1$gene))/100)
  indata2$inweight <- indata2[, inweight] / (length(unique(indata2$gene))/100)
  indata <- rbind(data.frame(indata1[, c('gene', 'inweight', 'asite.perc')], tag=intag1),
                  data.frame(indata2[, c('gene', 'inweight', 'asite.perc')], tag=intag2))

  return(
    ggplot(indata %>%
             filter(asite.perc>-0.1 & asite.perc<1.1),
           aes(x=asite.perc, weight=inweight, color=tag))+
      geom_freqpoly(binwidth=0.01, show.legend=F)+theme_classic()+
      geom_vline(xintercept=0, linetype='dashed', color='#006633')+
      geom_vline(xintercept=1, linetype='dashed', color='#66cc00')+
      scale_color_manual(values=c("#FF9900", "#3399FF"))+
      facet_wrap(~tag, scales='free_y', ncol=1)+
      geom_text(aes(label=lab), size=3,
                data=data.frame(lab=c(intag1, intag2),
                                tag=c(intag1, intag2)),
                x=-Inf, y=Inf, hjust=-0.2, vjust=1.2, inherit.aes = F)+
      theme(strip.background=element_blank(),
            strip.text.x=element_blank(),
            axis.title=element_text(size=9, color='black'),
            axis.text=element_text(size=8, color='black'),
            axis.line=element_line(size=0.4),
            axis.ticks=element_line(size=0.4))+
      xlab('Relative A-site on CDS')+
      ylab(iny)
  )
}

geno.rscu <- cal.rscu(500, as.character(unique(disome.perc$gene)))

{
  pdf('P1_rpm_distance.pdf', width=5, height=2.5, useDingbats=F)
  plot(
    plot.dis(dis5.sum, 'Distance from the first base of stop codon', 'Normalised RPM', -100, 10)
  )
  plot(
    plot.dis(dis5.sum, 'Distance from the first base of start codon', 'Normalised RPM', -50, 200, indis='dis5')
  )
  plot(
    plot.rela.dis(disome.perc, mono.perc, 'Disome', 'Monosome', 'rpm.nor', 'Normalised RPM')
  )
  dev.off()
  }

write.table(disome.perc, 'disome.perc.txt', sep='\t', quote=F, row.names=F)
write.table(mono.perc, 'mono.perc.txt', sep='\t', quote=F, row.names=F)

## stop codon percentage####
table(cds.sc$stop_codon)

ggplot(data=data.frame(sc=factor(c('TAA', 'TGA', 'TAG'), levels=c('TAG', 'TGA', 'TAA')),
                       num=c(2793, 1742, 1349)),
       aes(x=factor(1), y=num, fill=sc))+
  geom_bar(stat='identity', size=1)+coord_polar(theta='y')+
  theme_classic()+
  theme(legend.position='top',
        axis.line=element_blank(),
        axis.text.y=element_blank(),
        axis.title.y=element_blank(),
        axis.ticks=element_blank(),
        axis.title.x=element_text(size=12),
        axis.text.x=element_text(size=10),
        legend.background=element_blank(),
        legend.text=element_text(size=10),
        legend.key.size=unit(.8, 'cm'))+
  ylab('# of Yeast genes (5884 in Total)')+
  scale_y_continuous(breaks=c(0, 2793, 4535, 5884))+
  scale_fill_brewer(palette='Set2')

mrna.read.ordered.gene <- mrna.read[order(mrna.read$rpm, decreasing=T),]$gene
table(cds.sc[cds.sc$gene %in% mrna.read.ordered.gene[1:589],]$stop_codon)

{
  pdf('p2_stop_codon_percentage.pdf', width=7.5, height=3.6, useDingbats=F)
  multiplot(ggplot(data=data.frame(sc=factor(c('TAA', 'TGA', 'TAG'), levels=c('TAG', 'TGA', 'TAA')),
                                   num=c(2793, 1742, 1349)),
                   aes(x=factor(1), y=num, fill=sc))+
              geom_bar(stat='identity', size=1)+coord_polar(theta='y')+
              theme_classic()+
              theme(legend.position='top',
                    axis.line=element_blank(),
                    axis.text.y=element_blank(),
                    axis.title.y=element_blank(),
                    axis.ticks=element_blank(),
                    axis.title.x=element_text(size=12),
                    axis.text.x=element_text(size=10),
                    legend.background=element_blank(),
                    legend.text=element_text(size=10),
                    legend.key.size=unit(.8, 'cm'))+
              ylab('# of Yeast genes (5884 in Total)')+
              scale_y_continuous(breaks=c(0, 2793, 4535, 5884))+
              scale_fill_brewer(palette='Set2'),
            ggplot(data=data.frame(sc=factor(c('TAA', 'TGA', 'TAG'), levels=c('TAG', 'TGA', 'TAA')),
                                   num=c(385, 105, 99)),
                   aes(x=factor(1), y=num, fill=sc))+
              geom_bar(stat='identity', size=1)+coord_polar(theta='y')+
              theme_classic()+
              theme(legend.position='top',
                    axis.line=element_blank(),
                    axis.text.y=element_blank(),
                    axis.title.y=element_blank(),
                    axis.ticks=element_blank(),
                    axis.title.x=element_text(size=12),
                    axis.text.x=element_text(size=10),
                    legend.background=element_blank(),
                    legend.text=element_text(size=10),
                    legend.key.size=unit(.8, 'cm'))+
              ylab('# of top 1/10 expression Yeast genes (589 in Total)')+
              scale_y_continuous(breaks=c(0, 385, 385+105, 385+105+99))+
              scale_fill_brewer(palette='Set2'),
            cols=2)
  dev.off()
}
## the end ####


phase1 = phase
if (phase1 >= 0 and phase1 < 1):
    if (switchMaize==0):
        if (cumulTT >= dse):
            phase = 1#Emergence
        else:
            phase = phase1
    else:
        if (cumulTT >= dse):
            phase= 1#Emergence
        else:
            phase = phase1
elif (phase1 >= 1 and phase1 < 2):#EmergenceToFloralInitiation
    if ((isVernalizable==1 and vernaprog >= 1) or (isVernalizable==0)):
        if (switchMaize==0):
            if (dayLength > maxDL):
                finalLeafNumber = minFinalNumber
                hasLastPrimordiumAppeared = 1
            else:
                appFLN = minFinalNumber + sLDL * (maxDL - dayLength)
                    # calculation of final leaf number from daylength at inflexion plus 2 leaves
                if (appFLN / 2.0 <= leafNumber):
                    finalLeafNumber = appFLN
                    hasLastPrimordiumAppeared =1
                else:
                    phase = phase1
        else:
            hasLastPrimordiumAppeared = 1
            #CheckFloralInitiation
        if (hasLastPrimordiumAppeared==1):
                phase = 2#Floralinitiation
    else:
        phase = phase1
elif (phase1 >= 2 and phase1 < 4):#FloralInitiationToAnthesis
    if (isMomentRegistredZC_39==1):
                  #calculate the heading date
        if (phase1 < 3):
            ttFromLastLeafToHeading = 0.0
            if(choosePhyllUse=="Default"): ttFromLastLeafToHeading =(pFLLAnth - pHEADANTH) * fixPhyll
            elif (choosePhyllUse == "PTQ"): ttFromLastLeafToHeading = (pFLLAnth - pHEADANTH) * phyllochron
            elif (choosePhyllUse == "Test"): ttFromLastLeafToHeading = (pFLLAnth - pHEADANTH) * p
            if (cumulTTFromZC_39 >= ttFromLastLeafToHeading):
                    phase = 3
            else:
                phase = phase1
        else:
            phase = phase1
                    #CheckAnthesis;
        ttFromLastLeafToAnthesis =0.0
        if (choosePhyllUse == "Default"): ttFromLastLeafToAnthesis = pFLLAnth * fixPhyll
        elif (choosePhyllUse == "PTQ"): ttFromLastLeafToAnthesis = pFLLAnth * phyllochron
        elif (choosePhyllUse == "Test"): ttFromLastLeafToAnthesis = pFLLAnth * p
        if (cumulTTFromZC_39 >= ttFromLastLeafToAnthesis):
            phase = 4#Anthesis
    else:
        phase = phase1
elif (phase1 == 4):#AnthesisToEndCellDivision
                #CheckEndCellDivision
    if (grainCumulTT >= dcd):
        phase = 4.5#EndCellDivision
    else:
        phase = phase1
elif (phase1 == 4.5):#EndCellDivisionToEndGrainFill
                # CheckEndGrainFilling
    if (grainCumulTT >= dgf or gai <= 0):
        phase = 5#End of grain filling
    else:
        phase = phase1
elif (phase1 >= 5 and phase1 < 6):#EndGrainFillToMaturity
                #CheckMaturity
                #/<Comment>To enable ignoring grain maturation duration</Comment>
    localDegfm = degfm
    if (ignoreGrainMaturation==True): localDegfm = -1
    if (cumulTTFromZC_91 >= localDegfm ):
        phase = 6 #maturity
    else:
        phase= phase1
elif (phase1>= 6 and phase1 < 7):
    phase = phase1


###########################################################################################
### Table 3 simulation (linear)
###########################################################################################
eachCase <- function(case,eff=0)
    sapply(c('sh','ik','cft'),
           function(method) c(bias=case[paste0(method,'.est')]-eff,
                              cover=case[paste0(method,'.CIl')]<=eff &
                                  case[paste0(method,'.CIh')]>=eff,
                              width=case[paste0(method,'.CIh')]-
                                  case[paste0(method,'.CIl')])
        )

levTabCI <- function(res,eff=0){
    out <- NULL
     for(n in c(50,250,2500))
         for(err in c('norm','t')){
             run <- res[[paste(n,eff,err,sep='_')]]
            row <- NULL
            for(meth in c('cft','sh','ik'))
                row <- c(row,
                         if(is.list(run))
                             mean(sapply(run,function(x) x[paste0(meth,'.p')])<0.05,na.rm=TRUE)
                         else mean(run[paste0(meth,'.p'),]<0.05))

             out <- rbind(out,row)
             rownames(out)[nrow(out)] <- paste(err,n)
         }
    colnames(out) <- c('cft','sh','ik')
    out
}

displayCIsimHet <- function(res,tau=0,caption='',label=''){
  ## omit cases where one of the methods (ours?) didn't converge, gave NA
  res <- lapply(res,function(x) t(x[,apply(x,2,function(cc) !any(is.na(cc)))]))

  res <- res[grep(paste0('_tau',tau,'W'),names(res),fixed=TRUE)]
  res <- res[grepl('Wnone|Wt',names(res))]

  tab0 <- lapply(res,function(x)
    apply(sapply(1:nrow(x),function(i) eachCase(x[i,],eff=tau),simplify='array'),
      1:2,mean))

  tab0 <- lapply(tab0,function(xx){
    out <- rbind(sprintf("%.2f",round(xx[1,],2)),sprintf("%i",as.integer(round(xx[2,]*100))),sprintf("%.2f",round(xx[3,],2)))
    dimnames(out) <- dimnames(xx)
    out})

  cat('
\\begin{table}
\\footnotesize
\\begin{tabular}{ccc|ccc|ccc|ccc}
\\hline

&&& \\multicolumn{ 3 }{c}{Permutation}&\\multicolumn{ 3 }{c}{\`\`Limitless\'\'}&\\multicolumn{ 3 }{c}{Local OLS}\\\\
$n$& Effect& Error &', paste(rep(c('Bias','Cover.','Width'),3),collapse='&'),'\\\\
\\hline \n')
  for(n in c(50,250,2500))
#    for(err in c('norm','t')){
    for(rr in c('n0','t0','tt')){
      row <- NULL
      err <- ifelse(rr=='n0','norm','t')
      eff <- ifelse(rr=='tt','$t_3$',0)
      for(meth in c('cft','sh','ik'))
        row <- c(row,tab0[[paste0(n,'_err',err,'_tau',tau,'W',ifelse(rr=='tt','t','none'))]][,meth])
      if(err=='norm'){
        cat('\\hline \n')
        cat('\\multirow{3}{*}{',n,'} &0& $\\mathcal{N}(0,1)$ &')
      } else cat(' & ',eff,'& $t_3$ &')
      cat(paste(row,collapse='&'),'\\\\ \n')
    }
  cat('\\hline
\\end{tabular}
  \\caption{',caption,'}
  \\label{',label,'}\n',sep='')
  cat('\\end{table}\n')
}

dispAllSimp <- function(res){
  res <- sapply(res,function(x) t(x[,apply(x,2,function(cc) !any(is.na(cc)))]),simplify=FALSE)
  tab0 <- lapply(names(res),function(nn){
    x <- res[[nn]]
    tau <- ifelse(grepl('tau0.2',nn,fixed=TRUE),0.2,0)
    apply(sapply(1:nrow(x),function(i) eachCase(x[i,],eff=tau),simplify='array'),
      1:2,mean)
  })

  cond <- strsplit(names(res),'_')
  cond <- lapply(cond,function(x) gsub('err|tau','',x))
  cond <- lapply(cond,function(x) c(x[1],x[2],strsplit(x[3],'W')[[1]]))
  cond <- do.call('rbind',cond)
  out <- data.frame(tab0[[1]],stringsAsFactors=FALSE)
  out <- cbind(cond[rep(1,3),],c('Bias','Coverage','Width'),out)

  for(i in 2:length(tab0))
    out <- rbind(out,cbind(cond[rep(i,3),],
      c('Bias','Coverage','Width'),
      data.frame(tab0[[i]],stringsAsFactors=FALSE)))

  names(out) <- c('n','error','ATE','TE randomness','meas','Limitless','Local-OLS','Permutation')

  out
}

###########################################################################################
### Table 4 simulation (polynomial)
###########################################################################################

#' @export
## dgms <- function(tp){

##     ### the DGMs
##     curve(0.5*x,from=-1,to=1,ylim=c(-2,2),xlab='r',ylab='$\\EE[Y|R=r]$',main='Linear')
##     abline(v=0,lty=2)
##     curve(ifelse(abs(x)>0.5, 3*x+sign(x)*(0.5-3)*0.5,0.5*x),from=-1,to=1,ylim=c(-2,2),xlab='r',ylab='$\\EE[Y|R=r]$',main='Anti-Symmetric')
##     abline(v=0,lty=2)
##   #curve(ifelse(x>0.5,3*x+(0.5-3)*0.5,0.5*x),from=-1,to=1,ylim=c(-2,2),xlab='r',ylab='$\\EE[Y|R=r]$',main='One-Sided')
##   curve(mu4,from=-1,to=1,ylim=c(-2,2),xlab='r',ylab='$\\EE[Y|R=r]$',main='One-Sided')
##     abline(v=0,lty=2)
## }

dgms <- function(){
  lin <- function(x) 0.5*x
  as <- function(x) ifelse(abs(x)>0.5,3*x+sign(x)*(0.5-3)*0.5,lin(x))
  mu4 <- function(x) sin(3*x)
  p <- ggplot(data = data.frame(x = 0), mapping = aes(x = x))+xlim(-1,1)+
    theme(axis.line=element_blank(),
      axis.text.x=element_blank(),
      axis.text.y=element_blank(),
      axis.ticks=element_blank(),
      #axis.title.x='$r$',
      #axis.title.y='$\\EE[Y|R=r]$',
      legend.position="none",
      ## panel.background=element_blank(),
      ## panel.border=element_blank(),
      ## panel.grid.major=element_blank(),
      ## panel.grid.minor=element_blank(),
      ## plot.background=element_blank()
    )+xlab('$r$')+ylab('$\\EE[Y|R=r]$')

  gridExtra::grid.arrange(p+stat_function(fun=lin)+ggtitle('Linear'),
    p+stat_function(fun=as)+ggtitle('Anti-Symmetric'),
    p+stat_function(fun=mu4)+ggtitle('Sine'),nrow=1)
}

resTab <- function(run,full=FALSE){
    llr <- run[c(nrow(run)-1,nrow(run)),]
    run <- run[-c(nrow(run)-1,nrow(run)),]

    pvals <- run[seq(1,nrow(run)-1,2),]
    ests <- run[seq(2,nrow(run),2),]

    runPsh <- pvals[seq(1,nrow(pvals),2),]
    runPik <- pvals[seq(2,nrow(pvals),2),]

    runEstsh <- ests[seq(1,nrow(ests),2),]
    runEstik <- ests[seq(2,nrow(ests),2),]

    tabFun <- function(runP,runEst,full){
        tab <- rbind(
            level=apply(runP,1,function(x) mean(x<0.05,na.rm=TRUE)),
            RMSE=apply(runEst,1,function(x) sqrt(mean(x^2,na.rm=TRUE))))
        if(full) tab <- rbind(tab,
                              bias=rowMeans(runEst,na.rm=TRUE),
                              sd=apply(runEst,1,sd,na.rm=TRUE))
        tab
    }
    list(tabSH=tabFun(runPsh,runEstsh,full=full),
         tabIK=tabFun(runPik,runEstik,full=full),
         tabLLR=tabFun(rbind(llr[1,]),rbind(llr[2,]),full=full))
}

resTab <- function(run,full=FALSE){
  run <- run[,apply(run,2,function(x) !any(is.na(x)))]
  tabFun <- function(ests)
      rbind(
        bias=rowMeans(rbind(ests)),
        RMSE=sqrt(rowMeans(rbind(ests^2))))

  tabFunP <- function(ps)
    apply(rbind(ps),1,function(x) mean(x<0.05,na.rm=TRUE))

  out <- sapply(c('sh','ik','ll'),function(mm) tabFun(run[grep(paste0(mm,'.est'),rownames(run)),]),
    simplify=FALSE)

  if(full) out <- sapply(c('sh','ik','ll'),
    function(mm) rbind(out[[mm]],level= tabFunP(run[grep(paste0(mm,'.p'),rownames(run)),])),
    simplify=FALSE)

  out
}

#' @export
prntTab <- function(totalPoly,maxDeg=4,full=TRUE,md=FALSE){
    tab <- NULL

    if(maxDeg>(nrow(totalPoly[[1]])-2)/4){
        maxDeg <- (nrow(totalPoly[[1]])-2)/4
        if(!full)
            warning(paste('There don\'t seem to be that many degrees in the simulation.\n Setting maxDeg=',maxDeg))
    }

    ctab <- function(runname,full){
        run <- totalPoly[[runname]]
        res <- resTab(run,full=full)

        cbind(res[['sh']][,1:maxDeg],
              res[['ik']][,1:maxDeg],
              res[['ll']])
    }
    for(dgm in c('lin','antiSym','wass')){
        tab <- rbind(tab,ctab(paste0(dgm,'_t'),full))
        if(full) if(paste0(dgm,'_norm')%in%names(totalPoly)) tab <- rbind(tab,ctab(paste0(dgm,'_norm'),full))
    }
    if(md){
        colnames(tab) <- c(paste('LRD, deg=',1:maxDeg),paste('OLS, deg=',1:maxDeg),'Loc.Lin')
        rownames(tab) <- paste(rep(c('lin','antiSym','sine'),
          each=nrow(tab)/sum(rownames(tab)=='bias')),#,times=2),
          #rep(c('t err','norm err'),each=nrow(tab)/2),
          rownames(tab))
    }
    return(tab)
}

#' @export
polyLatex <- function(tab,full,caption='',label='tab:poly'){
    if(NCOL(tab)!=9) stop('This only works with polynomial degree=1,...,4')
    cat('
        \\begin{table}[ht]
\\centering
\\begin{tabular}{cr|llll|llll|l',ifelse(full,'|llll|llll|l}','}'),'
  \\hline \n')
    if(full) cat('&&\\multicolumn{9}{c|}{$t_3$ Errors} &\\multicolumn{9}{c|}{$\\mathcal{N}(0,1)$ Errors} \\\\ \n')

 cat('&& \\multicolumn{4}{c|}{Limitless} &  \\multicolumn{4}{c|}{OLS} &\\makecell[c]{Local\\\\Linear}',
        ifelse(full,'\\multicolumn{4}{c|}{Limitless} &  \\multicolumn{4}{c|}{OLS} &\\makecell[c]{Local\\\\Linear}',''),'\\\\
 \\multicolumn{2}{r|}{\\makecell[r]{Polynomial\\\\Degree}}&1&2&3&4&1&2&3&4&',ifelse(full,'&1&2&3&4&1&2&3&4&n/a','n/a'),' \\\\
')
    for(rr in 1:nrow(tab)){
        if(rr==1) cat('\\hline\n\\hline\n\\multirow{',ifelse(full,4,2),'}{*}{',ifelse(full,'\\begin{sideways}Linear\\end{sideways}','Linear'),'}')
        if(rr==3) cat('\\hline\n\\hline\n\\multirow{',ifelse(full,4,2),'}{*}{',ifelse(full,'\\begin{sideways}Anti-Sym\\end{sideways}','Anti-Sym'),'}')
        if(rr==5) cat('\\hline\n\\hline\n\\multirow{',ifelse(full,4,2),'}{*}{',ifelse(full,'\\begin{sideways}One-Side\\end{sideways}','One-Side'),'}')
        cat('&',rownames(tab)[rr],'&')
        cat(paste(sprintf("%.1f", round(tab[rr,],1)),collapse='&'))
        cat('\\\\ \n')
    }
    cat('
 \\hline
\\end{tabular}
\\caption{',caption,'}
\\label{',label,'}
\\end{table}\n',sep='')

}

#' @export
polyLatex5 <- function(tab,full,caption='',label='tab:poly'){
  if(NCOL(tab)!=11) stop('This only works with polynomial degree=1,...,5')
  tab2 <- tab
  for(i in 1:nrow(tab)) for(j in 1:ncol(tab))
                          tab2[i,j] <- ifelse(tab[i,j]>10,
                            sprintf("%i",as.integer(round(tab[i,j]))),
                            sprintf("%.1f",round(tab[i,j],1)))

    cat('
        \\begin{table}[ht]
\\centering
\\begin{tabular}{ll|ccccc|ccccc|c',ifelse(full,'|llll|llll|l}','}'),'
  \\hline \n')
    if(full) cat('&&\\multicolumn{11}{c|}{$t_3$ Errors} &\\multicolumn{11}{c|}{$\\mathcal{N}(0,1)$ Errors} \\\\ \n')

 cat('&& \\multicolumn{5}{c|}{Limitless} &  \\multicolumn{5}{c|}{OLS} &Local',
        ifelse(full,'\\multicolumn{5}{c|}{Limitless} &  \\multicolumn{5}{c|}{OLS} &Local',''),'\\\\
 && \\multicolumn{5}{c|}{Polynomial Degree}&\\multicolumn{5}{c|}{Polynomial Degree}&Linear',
 ifelse(full,'\\multicolumn{5}{c|}{Polynomial Degree}&\\multicolumn{5}{c|}{Polynomial Degree}&Linear',''),'\\\\
 DGM&Measure&1&2&3&4&5&1&2&3&4&5&',ifelse(full,'&1&2&3&4&1&2&3&4&5&',''),' \\\\
')
    for(rr in 1:nrow(tab)){
        if(rr==1) cat('\\hline\n\\hline\n\\multirow{',ifelse(full,4,2),'}{*}{',ifelse(full,'\\begin{sideways}Linear\\end{sideways}','Linear'),'}',sep='')
        if(rr==3) cat('\\hline\n\\hline\n\\multirow{',ifelse(full,4,2),'}{*}{',ifelse(full,'\\begin{sideways}Anti-Sym\\end{sideways}','\\makecell[c]{Anti-\\\\Sym}'),'}',sep='')
        if(rr==5) cat('\\hline\n\\hline\n\\multirow{',ifelse(full,4,2),'}{*}{',ifelse(full,'\\begin{sideways}One-Side\\end{sideways}','Sine'),'}',sep='')
        cat('&',rownames(tab)[rr],'&')
        cat(paste(tab2[rr,],collapse='&'))
        cat('\\\\ \n')
    }
    cat('
 \\hline
\\end{tabular}
\\caption{',caption,'}
\\label{',label,'}
\\end{table}\n',sep='')

}


## 03. Segurança Hidrica
## Autor: Gabriel Maia, Nexo Jornal
## Contato: dados@nexojornal.com.br

## pacote com as funcoes do nexo
library(nexo.utils)
## caso nao tenha instalado
## devtools::install_github('Nexo-Dados/nexo.utils')

#  Extrair os arquivos "ISH_Brasil_2015_light.zip" e "ISH_Brasil_2035_light.zip" para pastas com os mesmos nomes
#  esses shapefiles foram obtitos em 'https://metadados.ana.gov.br/geonetwork/srv/pt/main.home' e simplificados usando a ferramente 'https://mapshaper.org/'

# Bibliotecas e importação de dados ---------------------------------------

library(tidyverse)
library(sf)

read_rds("dados/attributes.rds") %>%
  mutate(ISH=fct_relevel(as_factor(ish_bra_gr), c("Mínimo", "Baixo", "Médio", "Alto", "Máximo")))->attributes_2035 #apenas a tabela de atributos de 2035, sem a geometria

read_sf("dados/ISH_Brasil_2015_light/ISH_2015.shp")->dados_2015 #shapefile e atributos de 2015

dados_2015 %>% cbind(attributes_2035)->dados2

# Visualizações -----------------------------------------------------------

dados_2015 %>%
  st_make_valid() %>%
  mutate(brasil=fct_relevel(as_factor(brasil), c("Mínimo", "Baixo", "Médio", "Alto", "Máximo"))) %>%
  group_by(brasil) %>%
  summarise() %>% #junta poligonos com o mesmo valor
  ggplot()+geom_sf(aes(fill=brasil), col=NA)+
  geom_sf(data=nexo.utils::mapState,fill=NA)+
  scale_fill_manual(values = c("#456994", "#5C8CC5","#85A9D4","#AEC6E2","#D7E3F1"))

nexo.utils::plot.export("Indice de degurança hidrica no territorio brasileiro 2015",1, 9999)

dados_2015 %>% cbind(attributes_2035) %>%
  st_make_valid() %>%
  group_by(ISH) %>%
  summarise() %>% #junta poligonos com o mesmo valor
  ggplot()+geom_sf(aes(fill=ISH), col=NA)+
  geom_sf(data=nexo.utils::mapState,fill=NA)+
  scale_fill_manual(values = c("#456994", "#5C8CC5","#85A9D4","#AEC6E2","#D7E3F1"))

nexo.utils::plot.export("Indice de degurança hidrica no territorio brasileiro 2035",2, 9999)

dados_2015 %>% cbind(attributes_2035) %>%
  mutate(brasil=fct_relevel(as_factor(brasil), c("Mínimo", "Baixo", "Médio", "Alto", "Máximo"))) %>%
  mutate(delta=case_when(as.numeric(brasil)>as.numeric(ISH)~"1.Diminuição",
                         as.numeric(brasil)==as.numeric(ISH)~"2.Estável",         #comparações entre o ISH 2015 e 2035
                         as.numeric(brasil)<as.numeric(ISH)~"3.Aumento")) %>%
  st_make_valid() %>%
  group_by(delta) %>%
  summarise() %>% #junta poligonos com o mesmo valor
  ggplot()+geom_sf(aes(fill=delta), col=NA)+
  geom_sf(data=nexo.utils::mapState,fill=NA)+
  scale_fill_manual(values = c("#F4CC36","#AEC6E2","#6BA99D"))

nexo.utils::plot.export("Indice de degurança hidrica no territorio brasileiro diff 2015-2035",3, 9999)

attributes_2035 %>%
  mutate( id=row_number()) %>%
  gather(Var, Val, ire_cs_amb:ire_cs_res) %>%
  arrange(id) %>% #altera o formato do dataset de wide para long em relação às dimensões
  mutate(Val=ifelse(Val==0,99, Val )) %>%  #altera o valor de NA de 0 para 99, para podermos usar min() para determinar a dimensão mais critica
  group_by(id) %>%
  mutate(atr_min=Var[which.min(Val)]) %>%
  select(id, atr_min) %>%
  unique() %>%
  left_join(dados_2015 %>% mutate( id=row_number()), "id") %>%  #adição dos polígonos
  st_as_sf() %>% st_make_valid() %>%
  select(atr_min, geometry) %>%
  group_by(atr_min) %>%
  summarise() %>% #junta poligonos com o mesmo valor
  ggplot()+geom_sf(aes(fill=atr_min), col=NA)+
  scale_fill_manual(values = c("#58D9B0","#FF7B80","#F4CC36","#6BA99D"))+
  facet_wrap(~atr_min)+
  geom_sf(data=nexo.utils::mapState,fill=NA)

nexo.utils::plot.export("Dimensão mais crítica do ISH",4, 9999)

attributes_2035 %>%
  mutate( id=row_number()) %>%
  gather(Var, Val, ire_cs_amb:ire_cs_res) %>% arrange(id) %>%
  mutate(Val=ifelse(Val==0,99, Val )) %>%
  group_by(id) %>%
  mutate(atr_min=Var[which.min(Val)]) %>%
  select(id, atr_min) %>%
  unique() %>%
  left_join(dados_2015 %>% mutate( id=row_number())) %>%
  st_as_sf() %>% ungroup()   ->dim_crits

st_area(dim_crits$geometry)%>%
  cbind(dim_crits$atr_min) %>% as_tibble() %>%
  set_names("area", "atr_min") %>%
  mutate(area2=as.numeric(area)) %>%
  group_by(atr_min) %>%
  summarise(area2=sum(area2)/10^6) %>%
  ggplot(aes(y=area2, x=1, fill= atr_min))+
  geom_bar(stat="identity")+
  scale_fill_manual(values = c("#58D9B0","#FF7B80","#F4CC36","#6BA99D"))

nexo.utils::plot.export("Areas das mais crítica do ISH",5, 9999)


library(tidyr)
library(ggplot2)

source("./config.r")
annotate_text_size <- 7
##############################################################################
# Experiment 1 data
da_exp <- read.csv("./outputs/simuls/synth_da/scores.csv", nrows = 5, header = F)
for (ii in c(2, 3, 4, 5, 1)){
  da_exp[ii,] <- da_exp[ii,] / da_exp[1,]
}
da_exp <- da_exp[2:5,] %>%
  gather(key = "estimator", value = "score")

estimator <- c("upper", "logdiag", "SPoC", "Riemann") %>%
  factor(, levels = c("upper", "logdiag", "SPoC", "Riemann"))
da_exp$estimator <- rep(estimator, times = 10)

distance <- read.csv("./outputs/simuls/synth_da/distance_a.csv", header = F)
da_exp$xaxis <- rep(distance[["V1"]], each = 4)

color_cats <- c(
  "#56B4E9",# sky blue
  "#009D79",# blueish green
  "#E36C2F",  #vermillon
  "#EEA535"  # orange
  # "#F0E442", #yellow
  # "#0072B2", #blue
  # "#CC79A7" #violet
)

ggplot(
  data = da_exp,
  mapping = aes(y = score, x = xaxis, group = estimator,
                color = estimator, fill = estimator)) +
  geom_hline(yintercept = 1., color = "black", linetype = "dotted",
             size = 1) +
  geom_line(size = 1.5, alpha = 0.8) +
  geom_point(fill = "white", size = 4, shape = 21) +
  my_theme +
  scale_x_continuous(breaks = seq(0, 3, 0.5)) +
  scale_y_continuous(limits = c(0, 1.10), breaks = seq(0, 1, 0.25)) +
  scale_color_manual(values = color_cats, name = NULL) +
  scale_fill_manual(values = color_cats, name = NULL) +
  annotate(geom = "text", x = 0.5, y = 1.1, label = "chance level",
           size = annotate_text_size) +
  labs(x = expression(mu),
       y = "Normalized MAE") +
  theme(legend.position = "top", legend.title = element_text(size = 16))

fname <- "./outputs/fig_1a_distance_loglinear"
ggsave(paste0(fname, ".png"), width = 5, height = 5, dpi = 300)
ggsave(paste0(fname, ".pdf"), width = 5, height = 5, dpi = 300,
  useDingbats = F)
embedFonts(file = paste0(fname, ".pdf"), outfile = paste0(fname, ".pdf"))

##############################################################################
# Experiment 2 data

da_exp2 <- read.csv(
  "./outputs/simuls/synth_da/scores_powers.csv", nrows = 5, header = F)
for (ii in c(2, 3, 4, 5, 1)){
  da_exp2[ii,] <- da_exp2[ii,] / da_exp2[1,]
}
da_exp2 <- da_exp2[2:5,] %>%
  gather(key = "estimator", value = "score")

estimator <- c("upper", "diag", "SPoC", "Riemann") %>%
  factor(, levels = c("upper", "diag", "SPoC", "Riemann"))
da_exp2$estimator <- rep(estimator, times = 10)

distance <- read.csv("./outputs/simuls//synth_da/distance_a.csv", header = F)
da_exp2$xaxis <- rep(distance[["V1"]], each = 4)

color_cats <- c(
  "#56B4E9",# sky blue
  "#009D79",# blueish green
  "#E36C2F",  #vermillon
  "#EEA535"  # orange
  # "#F0E442", #yellow
  # "#0072B2", #blue
  # "#CC79A7" #violet
)

ggplot(
  data = da_exp2,
  mapping = aes(y = score, x = xaxis, group = estimator,
                color = estimator, fill = estimator)) +
  geom_hline(yintercept = 1., color = "black", linetype = "dotted",
             size = 1) +
  geom_line(size = 1.5, alpha = 0.8) +
  geom_point(fill = "white", size = 4, shape = 21) +
    my_theme +
  scale_x_continuous(breaks = seq(0, 3, 0.5)) +
  scale_y_continuous(limits = c(0, 1.10), breaks = seq(0, 1, 0.25)) +
  scale_color_manual(values = color_cats, name = NULL) +
  scale_fill_manual(values = color_cats, name = NULL) +
  annotate(geom = "text", x = 0.5, y = 1.1, label = "chance level",
           size = annotate_text_size) +
  labs(x = expression(mu),
       y = "Normalized MAE") +
  theme(legend.position = "top", legend.title = element_text(size = 16))

fname <- "./outputs/fig_1a_distance_linear"
ggsave(paste0(fname, ".png"), width = 5, height = 5, dpi = 300)
ggsave(paste0(fname, ".pdf"), width = 5, height = 5, dpi = 300,
  useDingbats = F)
embedFonts(file = paste0(fname, ".pdf"), outfile = paste0(fname, ".pdf"))


\docType{data}
\name{flores}
\alias{flores}
\title{Datos sobre la flor Iris de Edgar Anderson}
\format{Un dataframe con 150 casos (filas) y 5 variables (columnas)
\describe{
\item{Largo.Sepalo}{Largo del sépalo}
\item{Ancho.Sepalo}{Ancho del sépalo}
\item{Largo.Petalo}{Largo del pétalo}
\item{Ancho.Petalo}{Ancho del pétalo}
\item{Especies}{A qué especie de la flor Iris corresponde (setosa, versicolor, virginica)}
}}
\usage{flores}
\description{El set de datos sobre la flor Iris entrega las medidas en centímetros del largo y ancho de los sépalos y los pétalos de 50 flores de 3 especies de Iris (setosa, versicolor y virginica).}
\keyword{datasets}


# Script to create combined results
library(xpose.nlmixr)
library(shinyMixR)
lapply(models,function(x){

  dir.create(paste0("./analysis/",x),showWarnings=FALSE)
  res      <- readRDS(paste0("./shinyMixR/",x,".res.rds"))
  ress     <- readRDS(paste0("./shinyMixR/",x,".ressum.rds"))
  xpdb     <- xpose_data_nlmixr(res)

  ptbl     <- cbind(Parameter=row.names(ress$partblf),ress$partblf)
  R3port::html_list(ptbl,porder=FALSE,title="Parameter table",out=paste0("./analysis/",x,"/01partable.html"),show=FALSE)

  gof_plot(res, outnm=paste0("./analysis/",x,"/02gofall.html"),mdlnm=x,show=FALSE)
  fit_plot(res, outnm=paste0("./analysis/",x,"/03indfit.html"),mdlnm=x,show=FALSE)
  pl1 <- prm_vs_iteration(xpdb)
  pl2 <- absval_res_vs_idv(xpdb, res = 'IWRES')
  pl3 <- absval_res_vs_pred(xpdb, res = 'IWRES')
  pl4 <- res_distrib(xpdb)
  R3port::html_plot(list(pl1,pl2,pl3,pl4),out=paste0("./analysis/",x,"/04other.html"),show=FALSE,title="other plots")

  etav <- nlme::ranef(res)[, -1];
  if(length(names(etav))!=0){
    pll <- lapply(names(etav),function(pl){
      ggplot(etav,aes_string(pl)) + geom_histogram(fill="grey",color="black") + labs(title=pl)
    })
    R3port::html_plot(pll,out=paste0("./analysis/",x,"/05hist.eta.html"),show=FALSE,title="ETA distribution")
  }
  R3port::html_plot(nlmixr::vpc(res,nsim=500,show=list(obs_dv=TRUE)),out=paste0("./analysis/",x,"/06vpc.plot.html"),show=FALSE,title="VPC")

  R3port::html_combine(combine=paste0("./analysis/",x),out="report.html",show=TRUE,
                       template=paste0(system.file(package="R3port"),"/bootstrap.html"),toctheme=TRUE)
})


library(ggplot2)
library(pheatmap)

# Note: These plots are generated from 5kb bins files, and intersections of
# bigWig files with bed files provided as supplementary data: IAPEz_consensus,
# ChromHMM17, RepMasker_lt200bp_all and TSS_hi.

# These tables can be downloaded from the extra data folder.

# Extended figure 13C - Repeats summary heatmap for H3K9me3, H3.3 and Smarcad1 ChIP.

tabledir <- './tables'
figdir <- './figures'

# Helper plot functions
compute.lims <- function(mat) {
  maxmat <- mat
  maxmat[is.na(maxmat)] <- -Inf
  maxval <- max(maxmat)

  minmat <- mat
  minmat[is.na(minmat)] <- Inf
  minval <- min(minmat)

  nsteps <- 21.0

  breaklim <- ceiling(abs(max(abs(c(minval, maxval)))))

  # Compute a reasonable amount of steps?
  stepsize <- 2*breaklim / nsteps

  breakslist <- seq(-breaklim, +breaklim, by=stepsize)
  breakslist
}

summary_heatmap <- function(values, title, size=35) {
  bcolor <- "white"

  breakslist <- compute.lims(values)
  palette <- colorRampPalette(rev(brewer.pal(n = 7, name = "RdBu")))(length(breakslist))

  cellsize <- size

  pheatmap(values,
           main=title,
           cellwidth=cellsize,
           cluster_rows=F,
           cluster_cols=F,
           cellheight=cellsize,
           border_color=bcolor,
           breaks=breakslist,
           color=palette,
           display_numbers=TRUE)
}

df <- read.csv(paste(tabledir, 'fig06_e_chromhmm_summary.csv', sep='/'), row.names=1)

results_wt <- df[, c("Navarro2020_WT_Input", "Navarro2020_WT_H33", "Navarro2020_WT_H3K9me3")]
results_kd <- df[, c("Navarro2020_Smarcad1KD_Input", "Navarro2020_Smarcad1KD_H33", "Navarro2020_Smarcad1KD_H3K9me3" )]
results_smarcad <- df[, c("Smarcad1_Input_FLAG", "Smarcad1_FLAG")]

results_norm <- cbind(log2(sweep(results_wt, 1, results_wt$Navarro2020_WT_Input, `/`)),
                      log2(sweep(results_kd, 1, results_kd$Navarro2020_Smarcad1KD_Input, `/`)),
                      log2(sweep(results_smarcad, 1, results_smarcad$Smarcad1_Input_FLAG, `/`)))

p <- summary_heatmap(t(results_norm[, c("Navarro2020_WT_H33",
                                        "Navarro2020_Smarcad1KD_H33",
                                        "Navarro2020_WT_H3K9me3",
                                        "Navarro2020_Smarcad1KD_H3K9me3")]),
                     title="ChromHMM summary (log2fc over input)")

ggsave(plot=p, paste(figdir, 'fig_13ext_repeats_summary_heatmap_a.png', sep='/'), width=20, height=5)

results_delta <- cbind(results_norm$Navarro2020_Smarcad1KD_H33 - results_norm$Navarro2020_WT_H33,
                       results_norm$Navarro2020_Smarcad1KD_H3K9me3 - results_norm$Navarro2020_WT_H3K9me3)

colnames(results_delta) <- c('delta_H33', 'delta_H3K9me3')

p <- summary_heatmap(t(results_delta),
                     title="RepMasker annotation (>200bp elements) (log2fc over input)")

ggsave(plot=p, paste(figdir, 'fig_13ext_repeats_summary_heatmap_b.png', sep='/'), width=20, height=5)

p <- summary_heatmap(t(results_norm[, c("Smarcad1_FLAG")]),
                     title="RepMasker annotation (>200bp elements) (log2fc over input)")
ggsave(plot=p, paste(figdir, 'fig_13ext_repeats_summary_heatmap_c.png', sep='/'), width=20, height=3)


context("test for lforld")

x1_10 <- 1 %..% 10
f <- lforce
test_that("test", {
  expect_equal(lfoldl(x1_10, `+`, 0), 55)
  expect_equal(lfoldr(x1_10, `+`, 0), 55)
  expect_equal(lfoldl1(x1_10, `+`), 55)
  expect_equal(lfoldr1(x1_10, `+`), 55)
  expect_identical(
    lforce(ltail(lscanl(liota(10), `+`, 0L))),
    lforce(lscanl1(liota(10), `+`))
  )
  expect_identical(
    f(lunfold_haskell(0L, function(x) if (x >= 10L) lempty else lcons(x, x + 1L))),
    f(liota(10)))

})


library("ggplot2")
library("sf")
library("maps")
library("rnaturalearth")
library("rnaturalearthdata")
library("plotly")
library("tidyr")

wrangle_states <- function(data) {
	# Get the states mapping data
	states <- st_as_sf(map("state", plot = FALSE, fill = TRUE))

	# Capitalize the state names
	states$ID <- tools::toTitleCase(states$ID)

	# Add area to states
	states$area <- as.numeric(st_area(states))

	# Join the Geometry and area data to Wine Data
	states_data <- rename(data, ID = state)
	states_data <- left_join(states_data, states, by = c("ID" = "ID"))

	# Group the data together to get it in it's final form
	states_data <- states_data %>%
	    group_by(ID) %>%
	    drop_na(price) %>%
	    summarise(mean_price = mean(price),
	              mean_rating = mean(points),
	              mean_value = mean(value),
	              area = mean(area),
	              num_reviews = n()) %>%
	    drop_na(area)

	states_data <- left_join(states, states_data, by = c("ID" = "ID", "area" = "area"))
	states_data <- states_data[, c(7, 1, 2, 3, 4, 5, 6)]
}

wrangle_counties <- function(data) {
	# Get the county mapping data (geometries)
	counties <- st_as_sf(map("county", plot=FALSE, fill=TRUE))

	# Configure the wine data so I can match Geometry's
	county_data <- data
	county_data$state <- lapply(county_data$state, function(x) str_to_lower(x))
	county_data$county <- lapply(county_data$county, function(x) str_to_lower(x))
	county_data <- unite(county_data, ID, c('state', 'county'), sep=',', remove = FALSE)

	# Join the Geometry data to the wine data
	county_data <- county_data %>%
	    mutate(ID = gsub(' county', "", ID))

	# Group the data together to get it in it's final form
	county_data <- county_data %>%
	    group_by(ID) %>%
	    drop_na(price) %>%
	    summarise(mean_price = mean(price),
	              mean_rating = mean(points),
	              mean_value = mean(value),
	              num_reviews = n()) %>%
	    drop_na(num_reviews)
	county_data <- left_join(counties, county_data, by = c("ID" = "ID"))
	county_data <- county_data[, c(6, 1, 2, 3, 4, 5)]
}

plot_states <- function(data, states_data) {

	# Set the gradient color scheme
	wine_colors <- c('#C7DBEA', '#CCCCFF', '#C1BDF4',
                     '#B6AEE9', '#948EC0', '#8475B2',
                     '#735BA4', '#624296', '#512888')

	states <- ggplot(data = states_data, aes(label = num_reviews)) +
	    geom_sf(data = states_data,
	            aes(fill = num_reviews)
	    ) +
	    scale_fill_gradientn(
	        colors = wine_colors,
	        space = "Lab",
	        trans="log10"
	    ) +
	    theme_void() +
	    labs(title = "Number of Wine Reviews by State",
	         fill = 'Num Reviews')

	ggplotly(states, width = 750, hoverinfo = "Num Reviews") %>%
	    style(hoveron = "fill")
}

plot_state <- function(data, state_value, county_data) {
	# Select the state to display from the input value
	state_value <- tolower(state_value)
	california <- county_data %>%
	    filter(grepl(paste0(state_value, ','), ID))

	# Set the gradient color scheme
	wine_colors <- c('#C7DBEA', '#CCCCFF', '#C1BDF4',
	                 '#B6AEE9', '#948EC0', '#8475B2',
	                 '#735BA4', '#624296', '#512888')

	state <- ggplot(data = california, aes(label = num_reviews)) +
	    geom_sf(data = california,
	            aes(fill = num_reviews)
	    ) +
	    scale_fill_gradientn(
	        colors = wine_colors,
	        space = "Lab",
	        trans="log10"
	    ) +
	    theme_void() +
	    labs(title = "Number of Wine Reviews by State",
	         fill = 'Num Reviews')
	ggplotly(state, width = 750, hoverinfo = "Num Reviews") %>%
	    style(hoveron = "fill")
}


#' Create a tidy stats data frame from a glm object
#'
#' \code{tidy_stats.glm} takes a glm object and converts the object to a tidy
#' stats data frame.
#'
#' @param model Output of \code{glm()}.
#' @param args Unused.
#'
#' @examples
#' # Get data
#' counts <- c(18,17,15,20,10,20,25,13,12)
#' outcome <- gl(3,1,9)
#' treatment <- gl(3,3)
#' d.AD <- data.frame(treatment, outcome, counts)
#'
#' # Run model
#' glm.D93 <- glm(counts ~ outcome + treatment, family = poisson())
#'
#' # Tidy stats
#' tidy_stats(glm.D93)
#'
#' @export

tidy_stats.glm <- function(model, args = NULL) {

  # Get summary statistics
  summary <- summary(model)

  # Convert model coefficients output to a data frame
  output_coefficients <- summary$coefficients %>%
    tibble::as_data_frame()
  # Not included: Descriptives of residuals, residual standard error, residual
  # degrees of freedom

  # Rename columns
  output_coefficients <- rename_columns(output_coefficients)

  # Set group and term information, and add degrees of freedom
  output_coefficients <- output_coefficients %>%
    dplyr::mutate(
      df = summary$df[2],
      term = names(model$coefficients),
      term_nr = 1:dplyr::n(),
      group = "coefficients")

  # Tidy stats
  output_coefficients <- output_coefficients %>%
    tidyr::gather("statistic", "value", -term, -term_nr, -group) %>%
    dplyr::arrange(term_nr)

  # Extract model fit statistics and immediately tidy the statistics
  output_model <- tibble::data_frame(
    group = "model",
    statistic = c("dispersion", "null deviance", "null deviance df",
      "residual deviance", "residual deviance df", "AIC",
      "Fisher Scoring iterations"),
    value = c(summary$dispersion, summary$null.deviance, summary$df.null,
      summary$deviance, summary$df.residual, summary$aic, summary$iter)
  )

  # Combine coefficients and model output
  output <- bind_rows(output_coefficients, output_model)

  # Add method
  output <- output %>%
    mutate(
      method = "Generalized linear model",
      notes = paste0("family: ", model$family$family, "; link function: ",
        model$family$link)
    )

  # Reorder columns
  output <- dplyr::select(output, group, term_nr, term, everything())

  return(output)
}


layout(matrix(c(1, 2, 1, 3, 4, 4), 3, 2, byrow = TRUE))
# another expression before drawing the plots
x <- 1 + 1
for (j in 1:2) {
  plot(rnorm(10))
  plot(rnorm(10))
  plot(rnorm(10))
  plot(rnorm(10))
}


# some times set in another program
#iter<-3  # number of iterations

library(MASS)
test<-F
useCovariance<-T

fit<-read.fit()
nopar<-fit$nopar
sigma<-fit$cov[1:nopar,1:nopar]

if (!useCovariance) {
 vari<-diag(sigma)
 sigma[,]<-0
 diag(sigma)<-vari
}

mu<-fit$est[1:nopar]
pars<-mvrnorm(n = iter, mu, sigma)

if (test) {
  hist(pars[,1]) # just a check
  m<-apply(pars,c(2),mean)
  std<-apply(pars,c(2),sd)
  CV<- std/m
  round(CV,2)
}

# write the sms.psv file
zz <- file(file.path(data.path,"sms.psv"), "wb")
writeBin(as.integer(nopar),zz)
for (i in (1:iter)) writeBin(as.double(pars[i,]),zz)

close(zz)

#testing
if (test) {
  zz <- file(file.path(data.path,"sms.psv"), "rb")
  nopar<-readBin(zz, integer())
  nopar
  a<-readBin(zz, numeric(), nopar )
  b<-readBin(zz, numeric(), nopar )
  a[1:10]
  b[1:10]
  a[1:10]/b[1:10]
  close(zz)
}


# Supporting function for the analysis of the data from the Fear Generalization Task (FGT) in the SAM study
# Written by Milou Sep

FGT_LMER_trialtype.Condition <- function(dataset){

  {
    ## 2way interactions ##
    # Define Models
    FullModel <-with(expr=lmer(FPS~1+Condition*trialtype+(1|pp), control=lmerControl(optimizer="bobyqa")),data = dataset, REML=F)
    Main_NO_2way<-with(expr=lmer(FPS~1+Condition+trialtype+(1|pp),control=lmerControl(optimizer="bobyqa")),data = dataset, REML=F)
    # Compare Models
    Condition.trialtype <- pool.compare(FullModel, Main_NO_2way, method='wald')

    ## Main effects ##
    # Define Models
    Main_Condition<-with(expr=lmer(FPS~1+trialtype+(1|pp),control=lmerControl(optimizer="bobyqa")),data = dataset, REML=F)
    Main_trialtype<-with(expr=lmer(FPS~1+Condition+(1|pp),control=lmerControl(optimizer="bobyqa")),data = dataset, REML=F)
    # Compare Models
    Condition <- pool.compare(Main_NO_2way,Main_Condition, method='wald')
    trialtype <- pool.compare(Main_NO_2way,Main_trialtype, method='wald')
  }

  # Table of model comparisons (Publication) --------------------------------
  twoway.C.T <- c("Condition x Trialtype", Condition.trialtype$Dm, Condition.trialtype$rm, Condition.trialtype$df1, Condition.trialtype$df2, Condition.trialtype$pvalue)
  Main.effect.Condition <- c("Condition", Condition$Dm, Condition$rm, Condition$df1, Condition$df2, Condition$pvalue)
  Main.effect.trialtype <- c("Trialtype", trialtype$Dm, trialtype$rm, trialtype$df1, trialtype$df2,  trialtype$pvalue)

  WORD.table.FGT <- data.frame(rbind(twoway.C.T ,
                                     Main.effect.Condition, Main.effect.trialtype))
  colnames(WORD.table.FGT) <- c("Model", "Dm", "rm", "df1", "df2", "pvalue")

  # Data cells need to be changed to numeric (not factor), otherwise problems with flextable().
  WORD.table.FGT[c(2,3,4,5,6)] <- sapply(WORD.table.FGT[c(2,3,4,5,6)], as.character) # First convert to character ..
  WORD.table.FGT[c(2,3,4,5,6)] <- sapply(WORD.table.FGT[c(2,3,4,5,6)], as.numeric) # .. then to numeric

  # Return function output --------------------------------------------------

  return(WORD.table.FGT)

}


#compare out of sample forecast to number of SVs within a group, among other things.
rm(list=ls())
source('paths.r')
library(data.table)
library(MASS)
library(corrplot)
library(caret)

#load in-/out-of-sample abundances and diversity stats.
cal.div <- readRDS(bahram_16S_common_phylo_fg_abun.path)
val.div <- readRDS(NEON_16S_phylo_fg_abundances.path)

# Load in calibration/validation models.
# cal <- readRDS(bahram_16S_prior_dmulti.ddirch_all.group_JAGSfits)
cal <- readRDS(paste0(scc_gen_16S_dir, "JAGS_output/prior_phylo_fg_JAGSfit_16S.rds"))
fg.cal <- readRDS(paste0(scc_gen_16S_dir, "JAGS_output/bahram_16S_prior_ddirch_fg_JAGSfits.rds"))
cal <- c(cal[1:5], fg.cal) # until the model is re-run, fg model must be loaded separately

# Load in forecast
val <- readRDS(NEON_cps_fcast_ddirch_16S.path)
val <- readRDS(paste0(pecan_gen_16S_dir, "/NEON_forecast_data/NEON_cps_fcast_ddirch_noLogMap.rds"))
# Load in validation data.
val.obs <- readRDS(NEON_phylo_fg_plot.site_obs_16S.path)

#Get calibration R2 values, merge in diversity stats.----
cal.r2_table <- list()
for(i in 1:length(cal)){
  cal_level <- cal[[i]]
  div <- cal.div[[i]]$group_frequencies
  pred <- cal_level$predicted
  obs <- cal_level$observed
  cal.lev_r2   <- list()
  cal.lev_r2.1 <- list()
  for(j in 1:ncol(pred)){
    mod <- lm(( obs[,j]) ~ (pred[,j]))
    cal.lev_r2[[j]] <- summary(mod)$r.squared
    #relative to 1:1 line.
    rss <- sum((pred[,j] - obs[,j]) ^ 2)       ## residual sum of squares
    tss <- sum((obs[,j] - mean(obs[,j])) ^ 2)  ## total sum of squares
    rsq.1 <- 1 - rss/tss
    rsq.1 <- ifelse(rsq.1 < 0, 0, rsq.1)
    cal.lev_r2.1[[j]] <- rsq.1
  }
  cal.lev_r2 <- data.frame(unlist(cal.lev_r2))
  cal.lev_r2 <- cbind(colnames(obs), cal.lev_r2)
  colnames(cal.lev_r2) <- c('group','cal_rsq')
  cal.lev_r2$cal_rsq.1 <- unlist(cal.lev_r2.1)
  #merge in diversity stats.
  colnames(div) <- c('group', 'cal_samp_freq','cal_N.SV','cal_diversity','cal_evenness')
  cal.lev_r2 <- merge(cal.lev_r2, div, all.x = T)
  cal.lev_r2 <- cal.lev_r2[-grep('other',cal.lev_r2$group),]
  cal.r2_table[[i]] <- cal.lev_r2
}
names(cal.r2_table) <- names(cal)

#get validation R2 values (site-level), merge in diversity stats.----
val.r2_table <- list() #full table
for(i in 1:length(val)){
  pred <-     val[[i]]$site.fit$mean
  obs <- val.obs[[i]]$site.fit$mean
  pred <- pred[,order(match(colnames(pred), colnames(obs)))]

  #make sure same order and identity of rownames
  obs <-  obs[rownames(obs ) %in% rownames(pred),]
  pred <- pred[rownames(pred) %in% rownames( obs),]
  rsq   <- list()
  rsq.1 <- list()
  abundance <- list()
  variance  <- list()
  range     <- list()
  for(j in 1:ncol(obs)){
    #get best-fit rsq.
    mod <- lm(obs[,j] ~ pred[,j])
    rsq[[j]] <- summary(mod)$r.squared
    #get rsq relative to 1:1 line.
   # rss <- sum((pred[,j] - obs[,j]) ^ 2)       ## residual sum of squares (-colin)
    rss <- sum(resid(mod)^2)      ## residual sum of squares
    tss <- sum((obs[,j] - mean(obs[,j])) ^ 2)  ## total sum of squares
    rsq_1 <- 1 - (rss/tss)
    rsq_1 <- ifelse(rsq_1 < 0, 0, rsq_1)
    rsq.1[[j]] <- rsq_1
    abundance[[j]] <- boot::inv.logit(mean(boot::logit(obs[,j])))
    variance[[j]] <- boot::inv.logit(  sd(boot::logit(obs[,j])))
    range[[j]] <- max(obs[,j]) - min(obs[,j])
  }
  rsq <- data.frame(unlist(rsq))
  rsq.1 <- data.frame(unlist(rsq.1))
  abundance <- data.frame(unlist(abundance))
  variance <- data.frame(unlist(variance))
  range <- data.frame(unlist(range))
  rsq <- cbind(colnames(obs), rsq, rsq.1,abundance, variance,range)
  colnames(rsq) <- c('group','val_rsq','val_rsq.1','val_abundance','val_variance','val_range')

  rsq$group <- as.character(rsq$group)
  div <- val.div[[i]]$group_frequencies
  colnames(div) <- c('group','val_samp_freq','val_N.SV','val_diversity','val_evenness')
  rsq <- rsq[-grep('other',rsq$group),]
  rsq <- merge(rsq, div, all.x = T)
  rsq$phylo_level <- names(val)[i]
  val.r2_table[[i]] <- rsq
}
names(val.r2_table) <- names(val)

#merge the tables.----
cal.stats <- do.call(rbind, cal.r2_table)
val.stats <- do.call(rbind, val.r2_table)
d <- merge(cal.stats, val.stats)

# rename functional groups
d[!d$phylo_level %in% c('phylum','class','order','family','genus'),]$phylo_level <- "fg"

#Model the R2 values.----

# Fungi results:
#vlaidation rsq of taxa with cal_rsq > 0.10.
#calibration and validation rsq are not related.
#validation rsq is related to validation variance, N.SVs (which are correlated). Best model just includes val_variance.
#diversity, N.SVs, variance all correlated, variance best predictor.
#also related to phylo level, but again, this mkaes val_variance model worse.
#true whether we model rsq or rsq.1
#--------

#### now for bacteria ####
mod <- lm(val_rsq ~ cal_rsq + phylo_level,data = d[d$cal_rsq > 0.1,])
summary(mod)

mod <- lm(val_rsq ~ cal_rsq + phylo_level,data = d[d$cal_rsq > 0.33,])
summary(mod)
par(mfrow = c(2,2)) # no clear patterns, other than with variance
plot(val_rsq ~ cal_rsq        , data = d[d$cal_rsq > 0.33,])
plot(val_rsq ~ log10(val_N.SV), data = d[d$cal_rsq > 0.1,])
plot(val_rsq ~ val_diversity  ,data = d[d$cal_rsq > 0.1,])
plot(val_rsq ~ val_variance   , data = d[d$cal_rsq > 0.1,])

# subset for stepwise regression
h <- d[d$cal_rsq > 0.33,]
x <- h[,!colnames(h) %in% c("val_rsq", "val_rsq.1", "group")]
fit <- lm(h$val_rsq ~ .,data=x)
step <- stepAIC(fit, direction="both")
summary(step)
step$anova # display results

# best model includes 7 predictors (so, most of them) and has an adjusted R2 of .5296
# doesn't account for collinearity:
summary(lm(d$val_rsq ~ cal_rsq.1 + val_rsq.1 + val_abundance + val_variance +
             val_range + val_samp_freq + val_N.SV + val_diversity + val_evenness, data=d))
# covariate correlation plot
dm = data.matrix(d[,!colnames(d) %in% c("val_rsq", "val_rsq1","phylo_level", "group")])
corrplot(cor(dm), order = 'hclust')

# can we see why phylum forecasts split neatly into good and bad???
# no. n=11 is too small. val_sample_freq is significant, except it's the phyla present in ~100% of samples that have 0% predictability...
p <- d[d$phylo_level=="phylum",]
t <- p[,!colnames(p) %in% c("val_rsq", "phylo_level", "group")]
summary(lm(val_rsq ~ val_samp_freq, data = p)) #p=.46
fit <- lm(p$val_rsq~.,data=t)
step <- stepAIC(fit, direction="both")
summary(step)
vif(fit)
sqrt(vif(fit)) > 2
plot(val_rsq ~ val_samp_freq, data = p, ylab = 'validation R2', xlab = 'val sample freq R2') # too few points

# all tax groups except phyla
np <- d[d$phylo_level != "phylum",]
summary(lm(val_rsq ~ val_samp_freq, data = np[np$cal_rsq > 0.1,]))

# ok, do functional groups show any trends?
fg <- d[d$phylo_level=="fg",]
mod <- lm(val_rsq ~ cal_rsq,data = fg[fg$cal_rsq > 0.33,])
summary(mod)
fit <- lm(fg$val_rsq ~ . ,data=fg[,-c(4,8,9,13,17)])
step <- stepAIC(fit, direction="both")
summary(step)
step$anova # display results

#When you subset to calibration R2 > 0.33, calibration does predict validation, R2 = 0.49, unadjusted. <- not true for bacteria at all :(
par(mfrow=(c(1,2)))
mod1 <- lm(val_rsq ~ cal_rsq, data = d[d$cal_rsq > 0.33,])
plot(val_rsq ~ cal_rsq, data = d[d$cal_rsq > 0.33,], ylab = 'validation R2', xlab = 'calibration R2')
abline(mod1, lwd = 2)
mtext(paste0('R2 = ',round(summary(mod1)$r.squared,2)), side = 3, line = -2, adj = 0.05)

#You can explain 88% (R2 = 0.88, unadjusted) if you add phylo/functional group to the model. <- also not true for bacteria
mod2 <- lm(val_rsq ~ cal_rsq + phylo_level, data = d[d$cal_rsq > 0.33,])
y <- d[d$cal_rsq > 0.33,]$val_rsq
x <- fitted(mod2)
plot(y ~ x, ylab = 'observed validation R2', xlab = 'predicted validation R2')
abline(lm(y~x), lwd = 2)
mtext(paste0('R2 = ',round(summary(mod2)$r.squared,2)), side = 3, line = -2, adj = 0.05)

# You can explain .59 (.52 adj) if you add a lot to the model
mod2 <- lm(val_rsq ~ cal_rsq.1 + cal_evenness + val_abundance + val_variance +
             val_range + val_samp_freq + phylo_level, data = d[d$cal_rsq > 0.33,])
y <- d[d$cal_rsq > 0.33,]$val_rsq
x <- fitted(mod2)
plot(y ~ x, ylab = NA, xlab = NA, bty =  'l', pch = 16, cex = 1.5, main = "val_rsq ~ cal_rsq.1 + cal_evenness \n+ val_abundance + val_variance +
             val_range + val_samp_freq + phylo_level, \n for cal_rsq > 0.33")
mtext(mtext(expression(paste("Observed Validation R"^"2")) , side = 2, line = 2.5))
mtext(mtext(expression(paste("Predicted R"^"2")), side = 1, line = 3))
abline(lm(y~x), lwd = 2)
mtext(paste0('R2 = ',round(summary(mod2)$r.squared,2)), side = 3, line = -2, adj = 0.05, cex = 1.2)

par(mfrow=c(1,2))

# cal.rsq and phylo level, both subsetted and not
mod3 <- lm(val_rsq ~ cal_rsq + phylo_level, data = d)
y <- d$val_rsq
x <- fitted(mod3)
plot(y ~ x, ylab = NA, xlab = NA, bty =  'l', pch = 16, cex = 1.5, main="val_rsq ~ cal_rsq + phylo_level")
mtext(mtext(expression(paste("Observed Validation R"^"2")) , side = 2, line = 2.5))
mtext(mtext(expression(paste("Predicted R"^"2")), side = 1, line = 3))
abline(lm(y~x), lwd = 2)
mtext(paste0('R2 = ',round(summary(mod3)$r.squared,2)), side = 3, line = -2, adj = 0.05, cex = 1.2)
mtext('b.', side = 1, line = -1.5, adj = 0.95, cex = 1.2)

mod4 <- lm(val_rsq ~ cal_rsq + phylo_level, data = d[d$cal_rsq > 0.33,])
y <- d[d$cal_rsq > 0.33,]$val_rsq
x <- fitted(mod4)
plot(y ~ x, ylab = NA, xlab = NA, bty =  'l', pch = 16, cex = 1.5, main = "val_rsq ~ cal_rsq + phylo_level,\n for cal_rsq > 0.33")
mtext(mtext(expression(paste("Observed Validation R"^"2")) , side = 2, line = 2.5))
mtext(mtext(expression(paste("Predicted R"^"2")), side = 1, line = 3))
abline(lm(y~x), lwd = 2)
mtext(paste0('R2 = ',round(summary(mod4)$r.squared,2)), side = 3, line = -2, adj = 0.05, cex = 1.2)

dev.off()