# ########################################
# ########## FUNCTIONS SECTION ############

###### CREATE BASIC ADJACENCY MATRIX #####
# no edge weights, useful for DCI with no distance decay
# rbgl requires adjacency matrix
# FIPEX outputs adjacency table so need to convert
# note: igraph requires only adjacency table

# library(rbenchmark) can be used to test
#https://stackoverflow.com/questions/34355892/build-a-square-adjacency-matrix-from-data-frame-or-data-tablelevs <- unique(unlist(neighbournodes_all, use.names=F))

create_basic_adjmatrix_2020 <- function(neighbournodes_all,option="2020_tapply") {
    # binary adjacency matrix defining connectivity

    if(option=="2020_tapply"){
        neighbournodes_all$edgeLength <- 1
        adj_matrix <- with(neighbournodes_all, tapply(edgeLength, list(Node1, Node2),FUN=length, default = 0))

    }else if(option=="2020_dfmatrix"){
        matrix_table <- table(neighbournodes_all)
        adj_mat1 <- as.data.frame.matrix(matrix_table)
        adj_matrix <- as.matrix(adj_mat1)

    }else if(option=="oldway"){

        # pre-2020 code
        segments<-with(neighbournodes_all, unique(Node2))
        #create a matrix with only 0's in them
        adj_matrix<-matrix(nrow=length(segments),
                       ncol=length(segments),
                       rep(0,length(segments)*length(segments)))
        segment_length<-length(segments)
        rownames(adj_matrix)<-colnames(adj_matrix)<-segments

        for (i in 1:segment_length){
            # find the segments in segment.matrix$Seg where segment.matrix$Seg_ID matches segments[i]
            # index of matching positions - this will be a vector of 1's and NA's
            pos_match<-	match(neighbournodes_all$Node2,segments[i])

            # keep only the positions where pos.match==1
            adj_segments<-neighbournodes_all$Node1[!is.na(pos_match)]

            # find the column positions that correspond to the adjacaent segments
            col<-match(adj_segments,segments)

            # the row number should correspond to i
            row<-i

            # assign a value of 1 for all values of row and col
            adj_matrix[row,col]<-1
        }
    }
    adj_matrix
}

################################################################
# edge-weighted connectivity list (edges_all) and matrix - for DCI w/ DD
# nodes / edges are not reversed as in original way
# do not need self-connected

create_advanced_adjmatrix_2020 <- function(FIPEX_table=NULL){

    # get connectivity list, convert columns to characters
    FIPEX_table_DD <- FIPEX_table %>% select(NodeEID,DownstreamEID,DownstreamNeighDistance) %>%
    mutate(temp = as.character(NodeEID)) %>%
    mutate(NodeEID = temp) %>%
    mutate(temp = as.character(DownstreamEID)) %>%
    mutate(DownstreamEID = temp) %>%
    select(-temp) %>%
    mutate(DownstreamEID = ifelse(DownstreamEID == "Sink","sink",DownstreamEID))

    # downstream neighbours
    edges_down <- FIPEX_table_DD

    # upstream neigbours
    edges_up <- FIPEX_table_DD %>% select(NodeEID,DownstreamEID,DownstreamNeighDistance) %>%
    mutate(temp = DownstreamEID) %>%
    mutate(DownstreamEID = NodeEID) %>%
    mutate(NodeEID = temp) %>%
    select(-temp)

    # self-connected
    #FIPEX_table %>% select(NodeEID,DownstreamEID,DownstreamNeighDistance) %>%
    #mutate(NodeEID = DownstreamEID, DownstreamNeighDistance = 0.1)

    # merge
    edges_all <- edges_down %>%
    bind_rows(edges_up) %>%
    #add_row(NodeEID = "sink", DownstreamEID = "sink") %>%
    rename(Node1 = NodeEID, Node2 = DownstreamEID, edgeLength = DownstreamNeighDistance)

    # convert to matrix
    adj_matrix_edgelengths <- with(edges_all, tapply(edgeLength, list(Node1, Node2), FUN=sum, default = 0))

    return(adj_matrix_edgelengths)
}

################################################################
# CREATE GRAPH OBJECT for DCI w/ Distance Decay
# edge weights are used for distance calculations
# edge data / attributes used for habitat quantity calculations
# #https://www.rdocumentation.org/packages/graph/versions/1.50.0/topics/graphAM-class
create_graph_dd_2020 <- function(adj_matrix_edgelengths=0.0,FIPEX_table=NULL){

    # Create graph object
    # 2020 - different way to call the graphAM function
    # vs pre-2020
    g_dd <- graphAM(adjMat=adj_matrix_edgelengths,  edgemode="directed", values=list(weight=1))

    # associate passabilities with nodes using NodeData slot
    # e.g. nodeData(g,n=c("b", "c"), attr ="color") <- "red"
    nodeDataDefaults(g_dd, attr ="pass") <- 1.0
    nodeData(g_dd,n=as.character(FIPEX_table$NodeEID), attr="pass") <- as.double(FIPEX_table$BarrierPerm)
    #nd <- nodes(g_dd)

    nodeDataDefaults(g_dd, attr ="nodelabel") <- "none"
    nodeData(g_dd,n=as.character(FIPEX_table$NodeEID), attr="nodelabel") <- as.character(FIPEX_table$NodeLabel)
    nodeData(g_dd,n="sink", attr="nodelabel") <- "sink"
    #nd <- nodes(g_dd)

    nodeDataDefaults(g_dd, attr ="downnodelabel") <- "none"
    nodeData(g_dd,n=as.character(FIPEX_table$NodeEID), attr="downnodelabel") <- as.character(FIPEX_table$DownstreamNodeLabel)
    #nd <- nodes(g_dd)

    nodeDataDefaults(g_dd, attr ="natural") <- "none"
    nodeData(g_dd,n=as.character(FIPEX_table$NodeEID), attr="natural") <- FIPEX_table$NaturalTF
    nodeData(g_dd,n="sink", attr="natural") <- FALSE
    #nd <- nodes(g_dd)

    # optionally can give edges attributes
    #edgeDataDefaults(g_dd, attr="name")<-"noname"
    #edgeData(self, from, to, attr)
    #edgeData(self, from, to, attr) <- value
    edgeDataDefaults(g_dd, attr="HabitatQuan")<-0.0
    edgeData(g_dd,from=as.character(FIPEX_table$NodeEID),
         to=as.character(FIPEX_table$DownstreamEID),
         attr="HabitatQuan")<-as.double(FIPEX_table$HabQuantity)
    # reverse - attr associated with each direction along one edge
    edgeData(g_dd,from=as.character(FIPEX_table$DownstreamEID),
         to=as.character(FIPEX_table$NodeEID),
         attr="HabitatQuan")<-as.double(FIPEX_table$HabQuantity)

    # give edges an easy-to-access name insensitive to direction
    # this is done to quickly identify duplicates later
    # there may be alternatives such as accessing edgeNames but I suspect
    # they are slower than this
    edgeDataDefaults(g_dd, attr="EdgeNameGO")<-"init"
    edgeData(g_dd,from=as.character(FIPEX_table$NodeEID),
         to=as.character(FIPEX_table$DownstreamEID),
         attr="EdgeNameGO")<-paste(as.character(FIPEX_table$DownstreamEID),
                                   as.character(FIPEX_table$NodeEID),
                                   sep="-")
    # reverse - attr associated with each direction along one edge
    edgeData(g_dd,from=as.character(FIPEX_table$DownstreamEID),
         to=as.character(FIPEX_table$NodeEID),
         attr="EdgeNameGO")<-paste(as.character(FIPEX_table$DownstreamEID),
                                   as.character(FIPEX_table$NodeEID),
                                   sep="-")
    return(g_dd)
}

################################################################################
# get all distances and paths (from penult) to all nodes from Sink / all nodes
# https://www.rdocumentation.org/packages/RBGL/versions/1.48.1/topics/dijkstra.sp
# note it must be node-node - no edge-edge possible
# note using this function repeatedly during DCIp is inefficient
# !!! (should use BFS w/ LCA i.e., custom algorithm) !!!
#   (cannot edit the source for Djikstra.sp because it's actually an
#   interface to C++ 'Boost'library for graphs - can't get edge and node attributes
#   during net traversal)

get_paths_distances <- function(g=NULL,fromnode="sink"){
    dijkstra.sp(g,fromnode,eW=unlist(edgeWeights(g)))

    # TO DO: ALTERNATIVES FOR BENCHMARKING
}

##############################################################################
##### SUMMARY TABLE 2020 #####

# replaces similar pre-2020 function to create a table for each edge-edge pair
# Includes options for alternative data management for benchmarking
# (code could be trimmed).
# this function could be sped up with custom algorithm that can find path
# while also grabbing attribute data (BFS w/ LCA).
# - G Oldford, 2020

# gets cumulative passability each pair using path info
# and get other attributes

# pseudocode:
# for each 'from node' (e.g., sink in DCId, and all nodes in DCIp)
#  get paths between node and all other node
#
#  for each 'to node' in 'all paths' results
#   get the first edge len and hab traversed from node to sink
#
#   store length and hab of the edge between 'to node' and first node encountered
#   in path back to 'from node' (i.e., the 'to edge')

#   do while next node name <> "from node"
#     pass = nodeData(g_dd, nextnode, "pass")
#     cumulativepass =  cumulativepass * pass
#     nextnode = the next node in path towards 'from node'
#     if last edge traversed on the way to 'from node'
#       store the length and habitat of this edge which is the 'from edge'
#     if there is a maxdistance set for distance decay,
#       add a TRUE/FALSE column to indicate this
#
#
#   add various other attributes to master table (attr's from g object)

# requires library(data.table)
# data.table vs other options likely to speed things up for large networks
#https://rstudio-pubs-static.s3.amazonaws.com/406521_7fc7b6c1dc374e9b8860e15a699d8bb0.html
#https://www.rdocumentation.org/packages/data.table/versions/1.13.0/topics/rbindlist

get_summary_tab_2020 <- function(option="dt-lists",
                                 naturalonly=FALSE,
                                 g = NULL,
                                 DCIp=FALSE,
                                 bDistanceLim=FALSE,
                                 dMaxDist=0.0){

    # funciton params:
    # option - for benchmarking speed of appending to table
    # naturalonly - will calculate pass-weighted path distances
    #  while ignoring non-natural barriers
    # g - the graph object (rbgl GraphAM in BioconductR)
    # DCIp - TRUE / FALSE will trigger loop that finds path
    #       between all nodes, node just sink
    # initialize empty data object in different ways

    # for different options and benchmarking:
    DT2 = data.table(FromNode="init",
                 ToNode="init",
                 FromNodeLabel="init",
                 ToNodeLabel="init",
                 CumulativePass=0.0,
                 FromEdgeLen=0.0,
                 ToEdgeLen=0.0,
                 TotalDist=0.0,
                 DistMinusStartEndLen=0.0,
                 DistMinusSEExceedsThreshold=FALSE,
                 FromEdgeHab=0.0,
                 ToEdgeHab=0.0,
                 ToEdgeName="init",
                 FromEdgeName="init",
                 ToFromEdgeNameCombo="init")

    DF2 = data.frame(FromNode="init",
                 ToNode="init",
                 FromNodeLabel="init",
                 ToNodeLabel="init",
                 CumulativePass=0.0,
                 FromEdgeLen=0.0,
                 ToEdgeLen=0.0,
                 TotalDist=0.0,
                 DistMinusStartEndLen=0.0,
                 DistMinusSEExceedsThreshold=FALSE,
                 FromEdgeHab=0.0,
                 ToEdgeHab=0.0,
                 ToEdgeName="init",
                 FromEdgeName="init",
                 ToFromEdgeNameCombo="init", stringsAsFactors=F)

    # lists in R must have size pre-allocated
    # size of our table is almost n^2 - n*(n-1)
    # (less than n^2 since not getting distance from node to itself)
    if(DCIp==FALSE){
        outlist <- vector("list", length(numNodes(g_dd)))
    }else{
        outlist <- vector("list", length(numNodes(g_dd)*(numNodes(g_dd)-1)))
    }

    outlist[[numNodes(g_dd)]] <- list(FromNode="init",
                 ToNode="init",
                 FromNodeLabel="init",
                 ToNodeLabel="init",
                 CumulativePass=0.0,
                 FromEdgeLen=0.0,
                 ToEdgeLen=0.0,
                 TotalDist=0.0,
                 DistMinusStartEndLen=0.0,
                 DistMinusSEExceedsThreshold=FALSE,
                 FromEdgeHab=0.0,
                 ToEdgeHab=0.0,
                 FromEdgeName="init",
                 ToEdgeName="init",
                 ToFromEdgeNameCombo="init")

    # from = sink / start node
    # to = other nodes
    if(DCIp==FALSE){
        fromnodecount=1
    }else{
        fromnodecount=numNodes(g_dd)
    }

    bDistMinusSEExceedsThreshold = FALSE
    count = 0
    for (j in 1:fromnodecount){
    #indendation for two nested for loops not done to save space
        if(DCIp==FALSE){
            fromnode_name = "sink"
            fromnode_label = "sink"
        }else{
            fromnode_name = nodes(g_dd)[j]
             if (fromnode_name=="sink"){
                fromnode_label = "sink"
            }else{
                fromnode_label = nodeData(g_dd, fromnode_name, "nodelabel")[[1]]
            }
        }

        ###########################################################
        #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        # get path & distances between 'fromnode' and all other nodes
        paths_distances <- get_paths_distances(g,fromnode_name)
        # this can be time consuming

    for (k in 1:length(paths_distances$penult)) {

        tonode <- paths_distances$penult[k]
        tonode_name = names(tonode)
        tonode_name <- tonode_name[[1]]
        tonode_label = nodeData(g_dd, tonode_name, "nodelabel")[[1]]

        if (tonode_name == fromnode_name){
            # not interested in distance from one node to itself
            next
        }
        count = count+1
        # initialize
        cumulativepass = 1.0
        pass = 1.0 # watch not to take pass from to/from end nodes since traversal starts at edge
        totaldistance = paths_distances$distances[tonode_name]
        totaldistance <- totaldistance[[1]]

        # get length of edge
        nextnode = paths_distances$penult[tonode]
        nextnode_name = names(nextnode)
        lastnode_name = tonode_name

        # get the last edge length traversed on the way to 'to node'
        # alternatively could grab the weight for this edge instead of subtraction
        toedgelen = totaldistance - paths_distances$distances[nextnode_name]
        toedgelen <- toedgelen[[1]]
        toedgedata =edgeData(g_dd, tonode_name,nextnode_name)
        toedgehab = toedgedata[[1]]$HabitatQuan
        toedgename = toedgedata[[1]]$EdgeNameGO

        exitvar = "go"
        while (exitvar != "stop"){

            if(nextnode_name != fromnode_name){
                pass = nodeData(g_dd, nextnode_name, "pass")
                if(naturalonly==FALSE){
                    cumulativepass = cumulativepass * pass[[1]]
                }else{
                    natural = nodeData(g_dd,nextnode_name,"natural")
                    if(natural[[1]]==TRUE){
                        cumulativepass = cumulativepass * pass[[1]]
                    }
                }
            }else{
                fromedgelen = paths_distances$distances[lastnode_name]
                fromedgelen <- fromedgelen[[1]]
                fromedgedata = edgeData(g_dd, lastnode_name,fromnode_name)
                fromedgehab = fromedgedata[[1]]$HabitatQuan
                fromedgename = fromedgedata[[1]]$EdgeNameGO

                exitvar="stop"
            }

            lastnode_name = nextnode_name
            nextnode = paths_distances$penult[nextnode]
            nextnode_name = names(nextnode)
        }

       distminusstartendlen = totaldistance - toedgelen - fromedgelen
       # less than zero distance indicates it's an edge-to-itself distance
       # correct for this
       if (distminusstartendlen<0){
          distminusstartendlen = 0
       }

       tofromedgename_combo = paste(toedgename,fromedgename,sep="|")

       if (bDistanceLim == TRUE){
           if (distminusstartendlen > dMaxDist){
               bDistMinusSEExceedsThreshold=TRUE
           }else{
               bDistMinusSEExceedsThreshold=FALSE
           }
       }else{
           bDistMinusSEExceedsThreshold=FALSE
       }

        if (option=="dt"){
            #print(cumulativepass)
            #https://www.rdocumentation.org/packages/data.table/versions/1.13.0/topics/rbindlist
            DT1 = data.table(FromNode=fromnode_name,
                     ToNode=tonode_name,
                     FromNodeLabel=fromnode_label,
                     ToNodeLabel=tonode_label,
                     CumulativePass=cumulativepass,
                     FromEdgeLen=fromedgelen,
                     ToEdgeLen=toedgelen,
                     TotalDist=totaldistance,
                     DistMinusStartEndLen=distminusstartendlen,
                     DistMinusSEExceedsThreshold = as.logical(bDistMinusSEExceedsThreshold),
                     FromEdgeHabLen=fromedgehablen,
                     ToEdgeHab=toedgehab,
                     FromEdgeHab=fromedgehab,
                     FromEdgeName=fromedgename,
                     ToEdgeName=toedgename,
                     ToFromEdgeNameCombo=tofromedgename_combo)
            l = list(DT1,DT2)

            DT2 = rbindlist(l, use.names=TRUE)
        }else if(option=="dt-lists"){
            # append lists to list rather than work yet with tables
            DL1 = list(FromNode=fromnode_name,
                     ToNode=tonode_name,
                     FromNodeLabel=fromnode_label,
                     ToNodeLabel=tonode_label,
                     CumulativePass=cumulativepass,
                     FromEdgeLen=fromedgelen,
                     ToEdgeLen=toedgelen,
                     TotalDist=totaldistance,
                     DistMinusStartEndLen=distminusstartendlen,
                     DistMinusSEExceedsThreshold = as.logical(bDistMinusSEExceedsThreshold),
                     FromEdgeHab=fromedgehab,
                     ToEdgeHab=toedgehab,
                     FromEdgeName=fromedgename,
                     ToEdgeName=toedgename,
                     ToFromEdgeNameCombo=tofromedgename_combo)
            #print("Length DL1: ")
            #print(length(DL1))
            outlist[[count]] <- (DL1)

        }else if(option=="df"){
            DF1 = data.frame(FromNode=fromnode_name,
                     ToNode=tonode_name,
                     FromNodeLabel=fromnode_label,
                     ToNodeLabel=tonode_label,
                     CumulativePass=cumulativepass,
                     FromEdgeLen=fromedgelen,
                     ToEdgeLen=toedgelen,
                     TotalDist=totaldistance,
                     DistMinusStartEndLen=distminusstartendlen,
                     DistMinusSEExceedsThreshold = as.logical(bDistMinusSEExceedsThreshold),
                     FromEdgeHab=fromedgehab,
                     ToEdgeHab=toedgehab,
                     FromEdgeName=fromedgename,
                     ToEdgeName=toedgename,
                     ToFromEdgeNameCombo=tofromedgename_combo)
            #print(fromedgehabarea)
            #print(DF1)
            DF2 <- rbind(DF2, DF1)
          }else if(option=="df-lists"){
            DL1 = list(FromNode=as.character(fromnode_name),
                     ToNode=as.character(tonode_name),
                     FromNodeLabel=as.character(fromnode_label),
                     ToNodeLabel=as.character(tonode_label),
                     CumulativePass=as.numeric(cumulativepass),
                     FromEdgeLen=as.numeric(fromedgelen),
                     ToEdgeLen=as.numeric(toedgelen),
                     TotalDist=as.numeric(totaldistance),
                     DistMinusStartEndLen=as.numeric(distminusstartendlen),
                     DistMinusSEExceedsThreshold = as.logical(bDistMinusSEExceedsThreshold),
                     FromEdgeHab=fromedgehab,
                     ToEdgeHab=toedgehab,
                     FromEdgeName=as.character(fromedgename),
                     ToEdgeName=as.character(toedgename),
                     ToFromEdgeNameCombo=as.character(tofromedgename_combo))
            outlist[[count]] <- (DL1)
        }else if(option=="dplyr"){
             DL1 = list(FromNode=as.character(fromnode_name),
                     ToNode=as.character(tonode_name),
                     FromNodeLabel=as.character(fromnode_label),
                     ToNodeLabel=as.character(tonode_label),
                     CumulativePass=as.numeric(cumulativepass),
                     FromEdgeLen=as.numeric(fromedgelen),
                     ToEdgeLen=as.numeric(toedgelen),
                     TotalDist=as.numeric(totaldistance),
                     DistMinusStartEndLen=as.numeric(distminusstartendlen),
                     DistMinusSEExceedsThreshold = as.logical(bDistMinusSEExceedsThreshold),
                     FromEdgeHab=as.numeric(fromedgehab),
                     ToEdgeHab=as.numeric(toedgehab),
                     FromEdgeName=fromedgename,
                     ToEdgeName=toedgename,
                     ToFromEdgeNameCombo=tofromedgename_combo)
            #print(row1)
            DF2 <- bind_rows(DF2,DL1)
        }
    } #k
    } #j

    if(option=="dt"){
        sum_tab <- DT2
    }else if(option=="dt-lists"){
        DT2 <- data.table(rbindlist(outlist))

        sum_tab <- DT2
    }else if(option=="df"){
        #DF2 <- DF2[!duplicated(DF2$ToFromEdgeNameCombo), ]
        sum_tab <- DF2
    }else if(option=="df-lists"){
        DF2 <- data.frame(do.call(rbind, outlist))
        #DF2 <- DF2[!duplicated(DF2$ToFromEdgeNameCombo), ]
        sum_tab <- DF2
    }else if(option=="dplyr"){
        sum_tab <- DF2
    }

    # if a distance limit, eliminate rows
    if(bDistanceLim == TRUE){
        return(sum_tab[DistMinusSEExceedsThreshold==FALSE])
    }else{
        return(sum_tab)
    }

}

#######################################################
###### Calculate DCI #####
#dci_calc_2020_dd <- function(){}
# warning: the sum_tab_2020 must be a data.table
#          only some data frames work ('dplyr' is ok not
#          the 'df-lists' option)

######### (1) DCId - calc_DCId #########
calc_DCId_2020 <- function(sum_tab_2020=NULL,
                           totalhabitat=0.0,
                           FromNode="sink",
                           bDistanceLim=FALSE){

    # filter table
    DCId_data<-subset(sum_tab_2020,FromNode=="sink")

    # Credit to Chris Edge Code for avoiding loops in R here:
    if(bDistanceLim==FALSE){
        DCId_data$temp <- DCId_data$CumulativePass * (DCId_data$ToEdgeHab/totalhabitat)
    }else{
        DCId_data$temp <- DCId_data$CumulativePass * (DCId_data$ToEdgeHabMaxAccessible/DCId_data$MaxTotalAccessHabFromEdge)
    }
    DCId <- sum(DCId_data$temp)
    return(round(DCId*100,2))
} # DCId

######### (2) DCIp - calc_DCIp #########
# Credit to C Edge for shorter code
calc_DCIp_2020 <- function(sum_tab_2020=NULL,
                           totalhabitat=0.0,
                           option="unique",
                           bDistanceLim=FALSE){

    # 'option' = unique / distinct for benchmarking speeds
    # unique = data.table / base r
    # distinct = dplyr
    # to do: sometimes sum_tab may be a data.table sometimes data.frame
    if(option=="unique"){
        sum_tab_2020 <- unique(sum_tab_2020, by = "ToFromEdgeNameCombo")
    }else{
        sum_tab_2020 <- distinct(sum_tab_2020, ToFromEdgeNameCombo, .keep_all = TRUE)
    }

    DCIp <- 0
    if(bDistanceLim==FALSE){
        for (i in 1:nrow(sum_tab_2020)) {
            DCIp <- DCIp + (sum_tab_2020$CumulativePass[i] * (sum_tab_2020$FromEdgeHab[i]/totalhabitat)) * (sum_tab_2020$ToEdgeHab[i]/totalhabitat)
        }
    }else{
        for (i in 1:nrow(sum_tab_2020)) {
            DCIp <- DCIp + (sum_tab_2020$CumulativePass[i] * (sum_tab_2020$FromEdgeHab[i]/totalhabitat))* (sum_tab_2020$ToEdgeHabMaxAccessible[i]/sum_tab_2020$MaxTotalAccessHabFromEdge[i])
        }
    }
    return(round(DCIp*100,2))
}

######### (3) DCIs - calc_DCIs #########
# can be added into (2) as option see below
calc_DCIs_2020 <- function (sum_tab_2020=NULL,
                            totalhabitat=0.0,
                            option="dt",
                            bDistanceLim=FALSE){

    # option: "dt","dplyr","old"
    # alternative methods for benchmarking
    if(option=="dt"){

        DCIs <- sum_tab_2020
        # remove duplicates
        DCIs <- unique(sum_tab_2020, by = "ToFromEdgeNameCombo")

        if(bDistanceLim==FALSE){
            # select only a required columns
            cols = c("FromEdgeName","ToEdgeHab","CumulativePass")
            DCIs <- DCIs[,..cols]
            # first step to DCIs
            DCIs[, DCIs_i := round(ToEdgeHab/totalhabitat * CumulativePass * 100,2)]
        }else{
            # select only a required columns
            cols = c("FromEdgeName","ToEdgeHabMaxAccessible","CumulativePass","MaxTotalAccessHabFromEdge")
            DCIs <- DCIs[,..cols]
            # first step to DCIs
            DCIs[, DCIs_i := round(ToEdgeHabMaxAccessible/MaxTotalAccessHabFromEdge * CumulativePass * 100,2)]
        }

        cols = c("FromEdgeName","DCIs_i")
        DCIs <- DCIs[,..cols]
        # second step to DCIs
        DCIs <- DCIs[, lapply(.SD,sum), by=.(FromEdgeName)]

    }else if(option=="dplyr"){

        if(bDistanceLim==FALSE){
            DCIs <- sum_tab_2020 %>%
            distinct(ToFromEdgeNameCombo, .keep_all = TRUE) %>%
            mutate(DCIs_i = CumulativePass * ToEdgeHab/totalhabitat * 100) %>%
            select(DCIs_i,FromEdgeName) %>%
            group_by(FromEdgeName) %>%
            summarise(DCIs = sum(DCIs_i))
        }else{
            DCIs <- sum_tab_2020 %>%
            distinct(ToFromEdgeNameCombo, .keep_all = TRUE) %>%
            mutate(DCIs_i = CumulativePass * ToEdgeHabMaxAccessible/MaxTotalAccessHabFromEdge)*100 %>%
            select(DCIs_i,FromEdgeName) %>%
            group_by(FromEdgeName) %>%
            summarise(DCIs = sum(DCIs_i))
        }

    }else if(option=="old"){
        sum_tab_2020 <- unique(sum_tab_2020, by = "ToFromEdgeNameCombo")
        sections<-as.vector(unique(sum_tab_2020$FromEdgeName))
        # store the all section results in DCI.as
        DCI_as<-NULL

        for(s in 1:length(sections)){
            DCI_s<-0
            # Old notes:
            # select out only the data that corresponds to pathways from one sectino
            # to all other sections
            d_nrows<-subset(sum_tab_2020, FromEdgeName==sections[s])
            d_sum_table<-d_nrows

            if(bDistanceLim==FALSE){
                for (a in 1:dim(d_nrows)[1]){
                    # Old note:
                    #to get the DCI for diadromous fish, use the following formula:
                    # DCId= li/L*Cj (where j= the product of the passability in the pathway)
                    la<-d_sum_table$ToEdgeHab[a]/sum(FIPEX_table$HabQuantity)
                    pass_d<-d_sum_table$CumulativePass[a]
                    DCI_s<-round(DCI_s+la*pass_d*100, digits=2)
                } # end loop over sections for dci calc
            }else{
                for (a in 1:dim(d_nrows)[1]){
                    # Old note:
                    #to get the DCI for diadromous fish, use the following formula:
                    # DCId= li/L*Cj (where j= the product of the passability in the pathway)
                    la<-d_sum_table$ToEdgeHabMaxAccessible[a]/d_sum_table$MaxTotalAccessHabFromEdge
                    pass_d<-d_sum_table$CumulativePass[a]
                    DCI_s<-round(DCI_s+la*pass_d*100, digits=2)
                } # end loop over sections for dci calc
            }
            DCI_as[s]<-round(DCI_s*100,2)
        } # end loop over "first" sections

        # STORE RESULTS IN .CSV file
        DCIs<-data.frame(sections,DCI_as)
    }else{
        print("error in options passed to calc_DCIs")
        DCIs <- 0.0
    }
    return(DCIs)
}

apply_distance_limits <- function(sum_tab_2020 = NULL,
                                bDistanceLim=FALSE,
                                dMaxDist=0.0,
                                bDistanceDecay=FALSE,
                                sDDFunction="none"){

    # calculate proportion of 'to edge' within the max distance and multiply
    #sum_tab_2020 <- sum_tab_2020 %>%
    #mutate(ToEdgeHabProp = (DistMinusStartEndLen+ToEdgeLen-dMaxDist)/ToEdgeLen) %>%
    #mutate(ToEdgeHabProp = ifelse(ToEdgeHabProp>=0,1-ToEdgeHabProp,1)) %>%
    #mutate(ToEdgeHabMaxAccessible = ToEdgeHabProp * ToEdgeHab) %>%
    #select(-ToEdgeHabProp)

    get_max_accessible <- function(DistMinusStartEndLen,ToEdgeLen,ToEdgeHab,dMaxDist){
        prop_accessible = (dMaxDist-DistMinusStartEndLen)/ToEdgeLen
        prop_accessible = ifelse(prop_accessible>0,prop_accessible,0)
        prop_accessible = ifelse(prop_accessible>1,1,prop_accessible)
        toedge_maxaccessible = prop_accessible * ToEdgeHab
        toedge_maxaccessible
    }

    sum_tab_2020[, ToEdgeHabMaxAccessible := get_max_accessible(DistMinusStartEndLen,
                                                                ToEdgeLen,ToEdgeHab,dMaxDist)]

    if(bDistanceDecay==TRUE & sDDFunction!="none"){
        sum_tab_2020 <- apply_distance_decay(sum_tab_2020,sDDFunction,dMaxDist)
        # overwriting here because totals below should be based on weighted hab
        sum_tab_2020$ToEdgeHabMaxAccessible = sum_tab_2020$toedgehabaccessible_dd
    }

    # sum habitat accessible from edge and add as attribute
    # in new column
    # remove duplicates first...
        # to do: dplyr is slower than data.table - re-code and benchmark
    sum_tab_hab <- sum_tab_2020 %>%
    distinct(ToFromEdgeNameCombo, .keep_all = TRUE) %>%
    group_by(FromEdgeName) %>%
    summarise(MaxTotalAccessHabFromEdge = sum(ToEdgeHabMaxAccessible))

    sum_tab_2020 <- sum_tab_2020 %>%
    left_join(sum_tab_hab, by = "FromEdgeName", copy=FALSE)

    return(data.table(sum_tab_2020))
}

apply_distance_decay <- function(sum_tab_2020=NULL,
                              sDDFunction="none",
                              dMaxDist = 0.0){

# distance decay options: "linear" - linear (1-x),
#                         "natexp1"- natural exponential #1 (general form: e^x),
#                         "natexp2" - natural exponential #2 (general form: e^x^2),
#                         "circle" - based on equation of circle ((1-x^2)^0.5)
#                         "sigmoid" - sigmoid (general form:1/(1+e^x)
# functions chosen because they can be integrated analytically.
# for analytical solutions see documentation.
# general form modified so intercepts are (0,1),(1,0) - sometimes approximate
# G Oldford, 2020

# to do: data.tables with many columns don't perform well and melt() may
#        help

########## General Formulas ##########
#  multiplies the 'maximum accessible habitat' at edge j by f_avg(a,b)
# (max accessible is pre-calculated earlier using cut-off value and distance of edge j from edge i)
#
# avg value of a dd function:
# f_avg(a,b,f(x)) = 1/(b-a)*integral_a_to_b(f(x)dx)
#           represents average value of distance decay function f(x) between
#           two positions, a and b, along total distance from end of edge i to maxdist
#           where a and b are positions from 0 to maxdist (maxdist is always
#           rescaled to 1.
# 'a' - proportion of maxdist reached at start of edge j
# 'b' - proportion of maxdist reached at end of edge j
    e = exp(1)

########## LINEAR distance decay function ##########
# function: (1-x) where x is proportion of maxdist
# f_avg = ((1-b)+(1-a))/2
# toedgehabaccessible_dd = f_avg(a,b)*ToEdgeHabMaxAccessible
    f_avg_linear <- function(a,b) {((1-b)+(1-a))/2}

########## natural exponential DD Function #1 ##########
########## general form: (-e^x) ##########
# parameterized function: f(x) = 1-e^(5(x-5)) with zero intercepts (0,1),(1,0)
# integral of f(x) = F_int = x - e^(5(x-1))/5)
# f_avg(a,b,f(x)) = 1/(b-a)*(b - e^(5(b-1))/5 -(a - e^(5(a-1))/5))
    integral_fx_natexp1 <- function(x){x-e^(5*(x-1))/5}
    f_avg_natexp1 <- function(a,b) {(1/(b-a)*(integral_fx_natexp1(b)-integral_fx_natexp1(a)))}

########## natural exponential DD Function #2 ##########
########## general form: -e^x^2 ##########
# parameterized function: f(x) = 2 - e^((x^2)*1/1.44)
# integral of f(x) = F_int = ((pi*i)^1/3 * erf(5*i*x/6)) / 5 + 2*x
# f_avg(a,b,f(x)) = to do
    # Note complete - can't be done without special erfi function
    erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
    integral_fx_natexp2 <- function(x){((pi*i)^1/3 * erf(5*i*x/6)) / 5 + 2*x}

########## CIRCULAR DD Function ##########
########## general form: (1-x^2)^0.5  ##########
# parameterized function: f(x) = (1-x^2)^0.5
# integral of f(x) = F_int = (asin(x)+x*(1-x^2)^0.5)/2
# f_avg(a,b,f(x)) = (asin(b)+b*(1-b^2)^0.5)/2 - (asin(a)+a*(1-a^2)^0.5)/2
    integral_fx_circle <- function(x){(asin(x)+x*(1-x^2)^0.5)/2}
    f_avg_circle <- function(a,b){((asin(b)+b*(1-b^2)^0.5)/2 - (asin(a)+a*(1-a^2)^0.5)/2)}

###### SIGMOID DD function ######
###### general form: 1/(e^x+1))######
# parameterized function: f(x) = 1/(e^(10(x*0.5)))+1
# integral f(x) = F_int = x - ln(e^10x+e^5)/10
# f_avg(a,b,f(x)) = 1/(b-a)*(b - ln(e^10b+e^5)/10- a - ln(e^10a+e^5)/10)
    integral_fx_sigmoid <- function(x){x - log(e^10*x+e^5)/10}
    f_avg_sigmoid <- function(a,b) {(1/(b-a)*(integral_fx_sigmoid(b)-integral_fx_sigmoid(a)))}

##### Calculate distance-decay weighted habitat accessible ######
##### (at each edge j from each each i)
    get_dd_habitat <- function(DistMinusStartEndLen,ToEdgeHabMaxAccessible,dMaxDist,sDDFunction){

        a = round(DistMinusStartEndLen/dMaxDist,3)
        b = round((DistMinusStartEndLen+ToEdgeHabMaxAccessible)/dMaxDist,3)

        a = ifelse(a<0,0,a)
        a = ifelse(a>1,1,a)
        b = ifelse(b<0,0,b)
        b = ifelse(b>1,1,b)

        if(sDDFunction=="linear"){
            toedgehab_dd <- ToEdgeHabMaxAccessible * f_avg_linear(a,b)
        }else if(sDDFunction=="natexp1"){
            toedgehab_dd <- ToEdgeHabMaxAccessible*f_avg_natexp1(a,b)
        }else if(sDDFunction=="natexp2"){
            # to do
        }else if(sDDFunction=="circle"){
            toedgehab_dd <- ToEdgeHabMaxAccessible*f_avg_circle(a,b)
        }else if(sDDFunction=="sigmoid"){
            toedgehab_dd <- ToEdgeHabMaxAccessible*f_avg_sigmoid(a,b)
        }

        # if the segment is tiny compared to cutoff distance
        # this can result in NaN's which cause issues.
        toedgehab_dd[ is.nan(toedgehab_dd) ] <- 0

        toedgehab_dd
    }

    sum_tab_2020[, toedgehabaccessible_dd := round(get_dd_habitat(DistMinusStartEndLen,
                                                                   ToEdgeHabMaxAccessible,
                                                                   dMaxDist,
                                                                   sDDFunction),2)]
    return(sum_tab_2020)

}

# ########################################
# ########## MAIN CODE SECTION ############

# intialize file with error code
write("ERROR",file='out_dd.txt')

# required libraries
library(RBGL)
library(data.table)
library(tidyverse)
# RBGL and Rgraphviz must be installed via BioconductR
#install.packages("BiocManager")
#BiocManager::install("Rgraphviz")
#BiocManager::install("RBGL")

# optional libraries
#library(Rgraphviz) # only needed for visuals
#library(rbenchmark)

########## 1) DATA PREP #########

# 'Advanced' table includes habitat, length, connectivity info in one table
FIPEX_table=read.csv("FIPEX_Advanced_DD_2020.csv")
# ensure it's "sink" not "Sink"
FIPEX_table <- FIPEX_table %>%
mutate(DownstreamEID = ifelse(DownstreamEID == "Sink","sink",as.character(DownstreamEID)))

# for testing only: natural TF set node 84 to natural barrier
#FIPEX_table[2,]$NaturalTF <- TRUE
#FIPEX_table

# The params file allows users to pass param settings
# to R from within the ArcMap software (new in 2020)
FIPEX_params=read.csv("FIPEX_2020_params.csv")

###### 2) PARAMETERIZATION #######

bDCISectional <- as.logical(FIPEX_params$bDCISectional)
bDistanceLim <- as.logical(FIPEX_params$bDistanceLim)
dMaxDist <- as.double(FIPEX_params$dMaxDist)
bDistanceDecay <- as.logical(FIPEX_params$bDistanceDecay)
sDDFunction <- as.character(FIPEX_params$sDDFunction)
# for testing:
#sDDFunction = "linear"
#sDDFunction = "natexp1"
#sDDFunction = "circle"
#sDDFunction = "sigmoid"
#sDDFunction = "none"
#bDistanceLim = FALSE
#dMaxDist = 1000
#bDistanceDecay = FALSE
naturalonly = FALSE
#bDCISectional = TRUE
bDCIp = TRUE

totalhabitat = sum(FIPEX_table$HabQuantity)
totallength = sum(FIPEX_table$DownstreamNeighDistance)

######### 3) NETWORK ANALYSIS #########

# build adjacency matrix
edgeweighted_adj_matrix <- create_advanced_adjmatrix_2020(FIPEX_table)

# build graph object
g_dd <- create_graph_dd_2020(edgeweighted_adj_matrix,FIPEX_table)

# build summary table (analyses to determine paths, pass, etc between edges)
sum_tab_2020 <- get_summary_tab_2020(option="dt-lists",
                                     naturalonly,
                                     g_dd,
                                     bDCIp,
                                     bDistanceLim,
                                     dMaxDist)

if(bDistanceLim==TRUE){
    sum_tab_2020 <- apply_distance_limits(sum_tab_2020, bDistanceLim, dMaxDist, bDistanceDecay, sDDFunction)
}

# for testing: turn all pass = 1 and DCI should = 1
#sum_tab_2020<- sum_tab_2020 %>% mutate(CumulativePass=1)
#sum_tab_2020 = as.data.table(sum_tab_2020)

######## 4) DCI CALC ########
DCId = 0.00
DCIp = 0.00
DCIs = 0.00

DCId <- calc_DCId_2020(sum_tab_2020,totalhabitat,"sink",bDistanceLim)
if(bDCIp==TRUE){
    DCIp <- calc_DCIp_2020(sum_tab_2020,totalhabitat,"unique",bDistanceLim)
	# sectional can only be run if DCIp has been selected
    if(bDCISectional==TRUE){
        DCIs <- calc_DCIs_2020(sum_tab_2020,totalhabitat,"dt",bDistanceLim)
    }
}

######## 5) Write to Files ######

# following previous output format
res<- data.frame(c(DCIp,DCId))
names(res)<-"value"
row.names(res)<-c("DCIp","DCId")
write.table(res,file='out_dd.txt')

# transform data to match what FIPEX expects
# DCIs 'FromEdgeName' 100-101 has first numbers as downstream node
# to align in FIPEX it can be adjusted to e.g., 100_s
# however, this results in more than one segment since, say, node
# 100 can have multiple upstream edges and nodes.
# To address this the _downstream_ segment DCI_s can be reported
# for each node in the system. This change will have to be carefully reported
# to the user!
if(bDCISectional==TRUE & bDCIp==TRUE){
    names(DCIs)[names(DCIs) == 'DCIs_i'] <- 'DCI_as'
    names(DCIs)[names(DCIs) == 'FromEdgeName'] <- 'section'

    #DCIs$sections <- paste(sub("\\-.*", "", DCIs$section),"_s",sep="")
    # there was a problem encountered with the above because it resulted
    # in more than one upstream segment associated with each node. I
    # reversed this but now need to be careful that the segmental DCI
    # is now reported as associated with the immediate _downstream_
    # segement from each node!
    DCIs$sections <- paste(sub(".*\\-", "", DCIs$section),"_s",sep="")

    DCIs$sections[DCIs$sections == "sink_s"] <- "sink"
    DCIs <- DCIs %>% select(sections,DCI_as)
    res<-data.frame(DCIs)
    write.table(x=res,
                file="DCI_all_sections_dd.csv",
                sep=",",
                row.names=F)
}


#!/usr/bin/env Rscript

# Read the inputs
# 1. genome_depth_bed
# 2. exon_depth_bed
# 3. intron_depth_bed
# 4. intergenic_depth_bed
# 5. output_image_file
args=commandArgs(trailingOnly=TRUE)
if(length(args)<5) {
  stop("Must supply inputs and output \n",call.=FALSE)
}
## decide output type
filex = substr(args[5],nchar(args[5])-2,nchar(args[5]))
if(filex=="pdf") {
  pdf(args[5],bg="#FFFFFF")
} else if (filex=="png") {
  png(args[5],bg="#FFFFFF")
} else {
    stop("Unsupported type for output file.\n",call.=FALSE)
}

dg<-read.csv(gzfile(args[1]),sep="\t",header=FALSE)
dexon<-read.csv(gzfile(args[2]),sep="\t",header=FALSE)
dintron<-read.csv(gzfile(args[3]),sep="\t",header=FALSE)
dinter<-read.csv(gzfile(args[4]),sep="\t",header=FALSE)

logtrans<-function(num) {
 if(num==1) {
   return(1)
 }
 return(log(num,2)+1)
}
untrans<-function(num) {
  if(num==1) {
    return(1)
  }
  return(2^(num-1))
}
neglogtrans<-function(num,lowest) {
  tymin = -1*log(lowest,2)
  return(-1*(-tymin+-1*log(num,2))/tymin)
}
xscale<-function(num,fac) {
  if(num==0) {
    return(0)
  }
  return(num**(fac))
}

fac = 4
maxval = max(dg[,4])
#par(las=2)
par(mar=c(5,5,1,1))
#par(mfrow=c(2,1))
plot(1,type="n",ylim=c(1,logtrans(maxval*2)),xlim=c(0,1),yaxt='n',xaxt='n',xlab="fraction of expressed feature",ylab="Depth",cex.lab=1.5)
yvals = seq(0,logtrans(maxval*2),1)
axis(2,at=yvals,labels=lapply(yvals,untrans))
xvals = seq(0,1,0.01)
axis(1,at=lapply(xvals,xscale,fac),labels=xvals)
d = dg[order(dg[,4]),]
tot = sum(d[,3]-d[,2])
lines((cumsum(d[,3]-d[,2])/tot)**fac,lapply(d[,4],logtrans),col="#777777",lwd=4)
d = dinter[order(dinter[,4]),]
tot = sum(d[,3]-d[,2])
lines((cumsum(d[,3]-d[,2])/tot)**fac,lapply(d[,4],logtrans),col="#0000FFAA",lwd=4)
d = dintron[order(dintron[,4]),]
tot = sum(d[,3]-d[,2])
lines((cumsum(d[,3]-d[,2])/tot)**fac,lapply(d[,4],logtrans),col="#D04FD0AA",lwd=4)
d = dexon[order(dexon[,4]),]
tot = sum(d[,3]-d[,2])
lines((cumsum(d[,3]-d[,2])/tot)**fac,lapply(d[,4],logtrans),col="#FF0000AA",lwd=4)
#fac = 1
#plot(1,type="n",ylim=c(1,logtrans(maxval*2)),xlim=c(0,1),yaxt='n',xaxt='n',xlab="fraction of coveraged genome",ylab="Depth",cex.lab=1.5)
#yvals = seq(0,logtrans(maxval*2),1)
#axis(2,at=yvals,labels=lapply(yvals,untrans))
#xvals = seq(0,1,0.01)
#axis(1,at=lapply(xvals,xscale,fac),labels=xvals)
#d = dg[order(dg[,4]),]
#tot = sum(d[,3]-d[,2])
#lines((cumsum(d[,3]-d[,2])/tot)**fac,lapply(d[,4],logtrans),col="#777777",lwd=4)
#d = dinter[order(dinter[,4]),]
#tot2 = sum(d[,3]-d[,2])
#dif = tot-tot2
#lines(((cumsum(d[,3]-d[,2])+dif)/tot)**fac,lapply(d[,4],logtrans),col="#0000FFAA",lwd=4)
#d = dintron[order(dintron[,4]),]
#tot2 = sum(d[,3]-d[,2])
#dif = tot-tot2
#lines(((cumsum(d[,3]-d[,2])+dif)/tot)**fac,lapply(d[,4],logtrans),col="#D04FD0AA",lwd=4)
#d = dexon[order(dexon[,4]),]
#tot2 = sum(d[,3]-d[,2])
#dif = tot-tot2
#lines(((cumsum(d[,3]-d[,2])+dif)/tot)**fac,lapply(d[,4],logtrans),col="#FF0000AA",lwd=4)
dev.off()


#########################################################################
# Simulation trial

trial <- function(tau=1.2) {
  args = commandArgs(trailingOnly=TRUE)
  config_id <- args[1] %>% as.numeric
  trial_id <- Sys.getenv('SLURM_ARRAY_TASK_ID') %>% as.numeric
  obs <- .obs(config_id)
  y <- obs$y; X <- obs$X; Z <- obs$Z; D <- obs$D; u <- obs$u
  n <- nrow(X); px <- ncol(X); pz <- ncol(Z)
  Sigma_z <- obs$Sigma_z
  Alpha0 <- obs$Alpha0
  sigma0_u <- obs$sigma0_u; sigma0_v <- obs$sigma0_v
  beta0 <- obs$beta0

  # first stage estimation
  lambda_j.Alpha0hat <- .lambda_j.Alpha0hat(X, Z, sigma0_v, tune_type = "CV")
  lambda_j <- lambda_j.Alpha0hat$lambda_j; Alpha0hat <- lambda_j.Alpha0hat$Alpha0hat

  # second-stage estimation
  D.hat <- Z %*% Alpha0hat
  lambda.beta_Lasso <- .lambda.beta_Lasso(y, D.hat, sigma0_u, no_pen_ids=c())
  lambda <- lambda.beta_Lasso$lambda; beta_Lasso_D.hat <- lambda.beta_Lasso$beta_Lasso

  # relaxed inverse estimation
  Sigma_d.hat <- .Sigmahat(D.hat)
  Id <- diag(1, px) # Identity matrix

  # Calculate JM estimator
  res_JM <- .Theta.hat_JM(Sigma_d.hat, n)
  Theta.hat_JM <- res_JM$Theta.hat; mus_JM <- res_JM$mus
  mu_stars_JM <- map_dbl(1:px,
    ~ { (Sigma_d.hat %*% Theta.hat_JM[.,] - Id[.,]) %>% abs %>% max})
  objs_JM <- map_dbl(1:px,
    ~ { Theta.hat_JM[.,] %>% abs %>% sum })

  # Calculate CLIME estimator
  mus_CLIME <- find_mus(Sigma_d.hat) * tau
  Theta.hat_CLIME <- .Theta.hat_CLIME(Sigma_d.hat, mus_CLIME)
  mu_stars_CLIME <- map_dbl(1:px,
    ~ { (Sigma_d.hat %*% Theta.hat_CLIME[.,] - Id[.,]) %>% abs %>% max})
  objs_CLIME <- map_dbl(1:px,
    ~ { Theta.hat_CLIME[.,] %>% abs %>% sum })

  # de-biased second-stage lasso estimation
  beta_debiased_CLIME <- .beta_debiased(y, X, D.hat, beta_Lasso_D.hat, Theta.hat_CLIME)
  beta_debiased_JM <- .beta_debiased(y, X, D.hat, beta_Lasso_D.hat, Theta.hat_JM)

  # Predict the second-stage noise
  u.hat <- y - X %*% beta_Lasso_D.hat
  sd_u.hat <- u.hat^2 %>% mean %>% sqrt

  # To record/compute estimate of Theta_jj (and Theta_jj)
  Theta <- solve(t(Alpha0) %*% Sigma_z %*% Alpha0)

  # Calculate remainder terms
  rem_1_CLIME <- (Theta.hat_CLIME-Theta)%*%t(D)%*%u/sqrt(n)
  rem_1_JM <- (Theta.hat_JM-Theta)%*%t(D)%*%u/sqrt(n)
  rem_2_CLIME <- Theta.hat_CLIME%*%t(D.hat-D)%*%u/sqrt(n)
  rem_2_JM <- Theta.hat_JM%*%t(D.hat-D)%*%u/sqrt(n)
  rem_3_CLIME <- Theta.hat_CLIME%*%t(D.hat)%*%(X-D.hat)%*%(beta_Lasso_D.hat-beta0)/sqrt(n)
  rem_3_JM <- Theta.hat_JM%*%t(D.hat)%*%(X-D.hat)%*%(beta_Lasso_D.hat-beta0)/sqrt(n)
  rem_4_CLIME <-sqrt(n)*(Theta.hat_CLIME%*%Sigma_d.hat-Id)%*%(beta_Lasso_D.hat-beta0)
  rem_4_JM <-sqrt(n)*(Theta.hat_JM%*%Sigma_d.hat-Id)%*%(beta_Lasso_D.hat-beta0)

  # Calculate main term
  w <- Theta%*%t(D)%*%u/sqrt(n)

  # estimator data
  df_est <- data.frame(
    config_id = rep(config_id, 3*px),
    trial_id = rep(trial_id, 3*px),
    estimator = c(rep("Debiased_CLIME", px), rep("Debiased_JM", px), rep("Lasso", px)),
    j = rep(1:px, 3),
    estimate_j = c(beta_debiased_CLIME, beta_debiased_JM, beta_Lasso_D.hat),
    beta0_j = rep(beta0, 3),
    SE1 = c(.SE1(Sigma_d.hat, Theta.hat_CLIME, sd_u.hat),
            .SE1(Sigma_d.hat, Theta.hat_JM, sd_u.hat),
            rep(NA, px)),
    SE2 = c(.SE2(D.hat, Theta.hat_CLIME, u.hat),
            .SE2(D.hat, Theta.hat_JM, u.hat),
            rep(NA, px)),
    SE3 = c(.SE3(Theta.hat_CLIME, sd_u.hat),
            .SE3(Theta.hat_JM, sd_u.hat),
            rep(NA, px)),
    Theta_jj = c(diag(Theta), diag(Theta), rep(NA, px)),
    Theta.hat_jj = c(diag(Theta.hat_CLIME), diag(Theta.hat_JM), rep(NA, px)),
    mu = c(mus_CLIME, mus_JM, rep(NA, px)),
    mu_stars = c(mu_stars_CLIME, mu_stars_JM, rep(NA, px)),
    objs = c(objs_CLIME, objs_JM, rep(NA, px)),
    w = c(w, w, rep(NA, px)),
    rem_1 = c(rem_1_CLIME, rem_1_JM, rep(NA, px)),
    rem_2 = c(rem_2_CLIME, rem_2_JM, rep(NA, px)),
    rem_3 = c(rem_3_CLIME, rem_3_JM, rep(NA, px)),
    rem_4 = c(rem_4_CLIME, rem_4_JM, rep(NA, px)),
    lambda_j = rep(lambda_j, 3)
  )
  # df_est <- data.frame(
  #   config_id = rep(config_id, 2*px),
  #   trial_id = rep(trial_id, 2*px),
  #   estimator = c(rep("Debiased_CLIME", px), rep("Lasso", px)),
  #   j = rep(1:px, 2),
  #   estimate_j = c(beta_debiased_CLIME, beta_Lasso_D.hat),
  #   beta0_j = rep(beta0, 2),
  #   SE1 = c(.SE1(Sigma_d.hat, Theta.hat_CLIME, sd_u.hat),
  #           rep(NA, px)),
  #   SE2 = c(.SE2(D.hat, Theta.hat_CLIME, u.hat),
  #           rep(NA, px)),
  #   SE3 = c(.SE3(Theta.hat_CLIME, sd_u.hat),
  #           rep(NA, px)),
  #   Theta_jj = c(diag(Theta), rep(NA, px)),
  #   Theta.hat_jj = c(diag(Theta.hat_CLIME), rep(NA, px)),
  #   mu_stars = c(mu_stars_CLIME, rep(NA, px)),
  #   objs = c(objs_CLIME, rep(NA, px))
  #   # vhat = rep(vhat, 2),
  #   lambda_j = rep(lambda_j, 2)
  # )

  # statistics
  mu_star_CLIME <- (Theta.hat_CLIME %*% Sigma_d.hat - diag(1, ncol(Sigma_d.hat))) %>% abs %>% max
  mu_star_JM <- (Theta.hat_JM %*% Sigma_d.hat - diag(1, ncol(Sigma_d.hat))) %>% abs %>% max
  mse_Debiased_CLIME <- (y - X %*% beta_debiased_CLIME)^2 %>% mean
  mse_Debiased_JM <- (y - X %*% beta_debiased_JM)^2 %>% mean
  mse_Lasso_D.hat <- (y - X %*% beta_Lasso_D.hat)^2 %>% mean

  # estimation statistics data
  df_stats <- data.frame(
    config_id = rep(config_id, 3),
    trial_id = rep(trial_id, 3),
    estimator = c("Debiased_CLIME", "Debiased_JM", "Lasso"),
    mse = c(mse_Debiased_CLIME, mse_Debiased_JM, mse_Lasso_D.hat),
    sd_u = rep(sd_u.hat, 3),
    # mu = c(mu, NA),
    tau = c(tau, NA, NA),
    mu_star = c(mu_star_CLIME, mu_star_JM, NA),
    # trial_cvg = c(trial_cvg, NA),
    lambda = rep(lambda, 3)
  )
  # df_stats <- data.frame(
  #   config_id = rep(config_id, 2),
  #   trial_id = rep(trial_id, 32),
  #   estimator = c("Debiased_CLIME", "Lasso"),
  #   mse = c(mse_Debiased_CLIME, mse_Lasso_D.hat),
  #   sd_u = rep(sd_u.hat, 2),
  #   # mu = c(mu, NA),
  #   tau = c(tau, NA),
  #   mu_star = c(mu_star_CLIME, NA),
  #   # trial_cvg = c(trial_cvg, NA),
  #   lambda = rep(lambda, 2)
  # )

  write.csv(df_est, paste("res/est_", config_id, "_", trial_id, ".csv", sep=""))
  write.csv(df_stats, paste("res/stats_", config_id, "_", trial_id, ".csv", sep=""))
}


# script to generate the umap plots used on the document

library('igraph')
library('umap')
library('tidyverse')

source('functions.r')

file_path = './data/Muestra_563_UC3M_fixed.TPS'
tps = read_tps(file_path, remove_point_5 = TRUE, n_cases = 563)
x_coord_names = tps$x_colnames
y_coord_names = tps$y_colnames
x_procrustes_coord_names = sprintf("x_%s_proc",1:length(x_coord_names))
y_procrustes_coord_names = sprintf("y_%s_proc",1:length(y_coord_names))
x_allom_coord_names = sprintf("x_%s_allom",1:length(x_coord_names))
y_allom_coord_names = sprintf("y_%s_allom",1:length(y_coord_names))

methods_graph = graph_from_literal(DATA-+DISTANCES,
                                   DATA-+PROCRUSTES,
                                   PROCRUSTES-+DISTANCES,
                                   PROCRUSTES-+ALLOMETRIC_SHAPE_REDUCTION,
                                   PROCRUSTES-+CLASSIFICATION_MODEL,
                                   PROCRUSTES-+COLINEARITY_TRIM,
                                   PROCRUSTES-+PCA,
                                   DISTANCES-+COLINEARITY_TRIM,
                                   DISTANCES-+PCA,
                                   DISTANCES-+CLASSIFICATION_MODEL,
                                   PCA-+CLASSIFICATION_MODEL,
                                   ALLOMETRIC_SHAPE_REDUCTION-+COLINEARITY_TRIM,
                                   ALLOMETRIC_SHAPE_REDUCTION-+CLASSIFICATION_MODEL,
                                   COLINEARITY_TRIM-+CLASSIFICATION_MODEL)

all_paths = all_simple_paths(methods_graph, from=1, to=5)

#################
DATA = function(data){
  tps$df
}

PROCRUSTES = function(data){
  procrustes_df = perform_procrustes(data, x_coord_names, y_coord_names, plot_procrustes=FALSE)
  procrustes_df %>% select(x_procrustes_coord_names, y_procrustes_coord_names)
}

DISTANCES = function(data){
  x_coords = colnames(data)[colnames(data) %>% str_detect('^x_')]
  y_coords = colnames(data)[colnames(data) %>% str_detect('^y_')]
  distances_raw = get_all_distances(data, x_coords, y_coords)
  distances_raw
}

PCA = function(data){
  pca_result = perform_pca_and_filter(data, columns=NULL, max_explained_var=0.95)
  pca_result
}

COLINEARITY_TRIM = function(data){
  x_columns = colnames(data)
  non_colinear_cols = get_noncolinear_columns(data, columns = x_columns, max_percentage=0.96, plot_correlation=FALSE)
  data %>% select(non_colinear_cols)
}

ALLOMETRIC_SHAPE_REDUCTION = function(data){
  gpa = perform_procrustes(DATA(), x_coord_names, y_coord_names, plot_procrustes=FALSE, return_object=TRUE)
  data = remove_allometric_shape_effect(data, gpa)
  data %>% select(c(x_allom_coord_names, y_allom_coord_names))
}
#################3

umap.config = umap::umap.defaults
umap.config$n_neighbors = 25

set.seed(42)
for(path in all_paths){
  t_name = path$name[-c(1,length(path$name))] %>% paste(collapse='->')
  method_data = DATA()
  for(stage in path$name[-c(1, length(path$name))]){
    method_data = match.fun(stage)(method_data)
  }

  df.umap = umap(scale(method_data), config = umap.config)
  gg.data = data.frame(x=df.umap$layout[,1], y=df.umap$layout[,2], diagnosis=tps$df$diagnosis)
  gg1 = ggplot(gg.data, aes(x=x,y=y, color=diagnosis)) + geom_jitter()  + geom_point(alpha = 1/10, size = 0.1, stroke = 0, shape = 16) +
    ggtitle(t_name, subtitle = '') + theme(plot.title = element_text(size = 8))

  df.umap = cbind(method_data, DATA() %>% select(sex))
  df.umap['sex'] = lapply(df.umap['sex'], factor)
  df.umap['sex'] = lapply(df.umap['sex'], as.numeric)
  df.umap = umap(scale(df.umap), config = umap.config)
  gg.data = data.frame(x=df.umap$layout[,1], y=df.umap$layout[,2], diagnosis=tps$df$diagnosis)
  gg2 = ggplot(gg.data, aes(x=x,y=y, color=diagnosis)) + geom_jitter()  + geom_point(alpha = 1/10, size = 0.1, stroke = 0, shape = 16) +
    ggtitle(t_name, subtitle = '+ sex') + theme(plot.title = element_text(size = 8))

  df.umap = cbind(method_data, DATA() %>% select(age_group))
  df.umap['age_group'] = lapply(df.umap['age_group'], factor)
  df.umap['age_group'] = lapply(df.umap['age_group'], as.numeric)
  df.umap = umap(scale(df.umap), config = umap.config)
  gg.data = data.frame(x=df.umap$layout[,1], y=df.umap$layout[,2], diagnosis=tps$df$diagnosis)
  gg3 = ggplot(gg.data, aes(x=x,y=y, color=diagnosis)) + geom_jitter()  + geom_point(alpha = 1/10, size = 0.1, stroke = 0, shape = 16) +
    ggtitle(t_name, subtitle = '+ age_group') + theme(plot.title = element_text(size = 8))

  df.umap = cbind(method_data, DATA() %>% select(sex, age_group))
  df.umap['sex'] = lapply(df.umap['sex'], factor)
  df.umap['sex'] = lapply(df.umap['sex'], as.numeric)
  df.umap['age_group'] = lapply(df.umap['age_group'], factor)
  df.umap['age_group'] = lapply(df.umap['age_group'], as.numeric)
  df.umap = umap(scale(df.umap), config = umap.config)
  gg.data = data.frame(x=df.umap$layout[,1], y=df.umap$layout[,2], diagnosis=tps$df$diagnosis)
  gg4 = ggplot(gg.data, aes(x=x,y=y, color=diagnosis)) + geom_jitter()  + geom_point(alpha = 1/10, size = 0.1, stroke = 0, shape = 16) +
    ggtitle(t_name, subtitle = '+ sex + age_group')+ theme(plot.title = element_text(size = 8))

  gg_c = ggpubr::ggarrange(gg1, gg2, gg3, gg4, nrow = 2, ncol=2, common.legend = TRUE, legend="right")
  file_name = paste('../cluster_images/', t_name %>% str_replace('->','_'), '.png', sep='')
  ggsave(plot=gg_c, filename=file_name, width=24, height = 24, units='cm', device = 'png')
}


require(Hmisc)
n <- 100
f <- function(na=FALSE) {
  x <- sample(c('N', 'Y'), n, TRUE)
  if(na) x[runif(100) < .1] <- NA
  x
}
set.seed(1)
d <- data.frame(x1=f(), x2=f(), x3=f(), x4=f(), x5=f(), x6=f(), x7=f(TRUE),
                age=rnorm(n, 50, 10),
                race=sample(c('Asian', 'Black/AA', 'White'), n, TRUE),
                sex=sample(c('Female', 'Male'), n, TRUE),
                treat=sample(c('A', 'B'), n, TRUE),
                region=sample(c('North America','Europe'), n, TRUE))

d <- upData(d, labels=c(x1='MI', x2='Stroke', x3='AKI', x4='Migraines',
                 x5='Pregnant', x6='Other event', x7='MD withdrawal',
                 race='Race', sex='Sex'))

dasna <- subset(d, region=='North America')
with(dasna, table(race, treat))

png('/tmp/summaryP.png', width=550, height=550)
yy <- with(d, ynbind(x1, x2, x3, x4, x5, x6, x7, label='Exclusions'))
print(unclass(yy))
print(yy[,1])
print(attributes(yy[,1]))
table(yy[,1])
print(yy[,1:2])
print(attributes(yy[,1:2]))

s <- summaryP(race + sex + ynbind(x1, x2, x3, x4, x5, x6, x7,
                                  label='Exclusions') ~
              region + treat,  data=d)
# add exclude1=FALSE to include female category
plot(s, val ~ freq | region * var, groups='treat')  # best looking
dev.off()

plot(s, groups='treat')
# plot(s, groups=treat, outerlabels=FALSE) for standard lattice output
plot(s, groups='region', key=list(columns=2, space='bottom'))
g <- ggplot(s, groups='treat')
plotly::ggplotly(g, tooltip='text')   # poor output
s <- summaryM(race + sex + x1 + x2 ~ treat + region, data=d)
options(grType='plotly')
plot(s)

options(grType='base')

plot(s <- summaryP(race + sex ~ region, data=d, exclude1=FALSE), col='green')

# Make your own plot using data frame created by summaryP
dotplot(val ~ freq | region * var, data=s,   # was groups=treat
        xlim=c(0,1), scales=list(y='free', rot=0), xlab='Fraction',
        panel=function(x, y, subscripts, ...) {
          denom <- s$denom[subscripts]
          x <- x / denom
          panel.dotplot(x=x, y=y, subscripts=subscripts, ...) })


#  James Rekow

identifySubgroupsVer1 = function(abdList, rollRange = 0.025, numClust = NULL){

  #  ARGS: rollRange - the maximum difference in overlap between two DOC points for which the two points
  #                    are still considered close enough that they are included in each others local
  #                    dissimilarity profiles (e.g. in computing rolling mean, etc.)
  #
  #  RETURNS: subgroupsGuess - vector of indices grouping input samples by subgroup. e.g. subgroupIxVec =
  #                            c(1, 1, 1, 2, 2) would indicate that samples 1:3 are in a subgroup together,
  #                            and samples 4 and 5 are in a separate subgroup together

  source("computeInfoWeightMat.r")
  source("identifyNumSubgroups.r")

  #  compute matrix of info weights
  infoMat = computeInfoWeightMat(abdList = abdList, rollRange = rollRange)

  #  use identify numsubgroups to identify correct number of subgroups, if an expected number of clusters
  #  isn't provided
  if(is.null(numClust)){
    numClust = identifyNumSubgroups(infoMat = infoMat)
  } #  end if

  #  use kmeans to identify subgroups of samples, putting them into numClust clusters
  subgroupsGuess = kmeans(x = infoMat, centers = numClust, iter.max = 1000, nstart = 100)$cluster

  return(subgroupsGuess)

} #  end identifySubgroupsVer1 function


library(here)
data = readRDS(here("src/epidemia_fixed_seed.rds"))
library(rstan)

options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
m = stan_model(here("stan-models/epidemia_fixed_seed.stan"))

fit = sampling(m, data=data, iter=400, control = list(max_treedepth=15, adapt_delta=0.9),thin=4,seed=1)


library(RWeka)
trainset <- read.csv("/Users/byu/Desktop/Data/titanic-train.csv")
testset <- read.csv("/Users/byu/Desktop/Data/titanic-test.csv")
NN <- make_Weka_filter("weka/filters/unsupervised/attribute/NumericToNominal")
trainset <- NN(data=trainset, control= Weka_control(R="1-3"), na.action = NULL)
testset <- NN(data=testset, control= Weka_control(R="1,3"), na.action = NULL)
MS <- make_Weka_filter("weka/filters/unsupervised/attribute/ReplaceMissingValues")
trainset <-MS(data=trainset, na.action = NULL)
testset <-MS(data=testset, na.action = NULL)

model 1: no feature engineering

m=J48(Survived~., data = trainset, control=Weka_control(U=FALSE, M=2, C=0.5))
e <- evaluate_Weka_classifier(m, numFolds = 10, seed = 1, class = TRUE)
pred=predict (m, newdata = testset, type = c("class"))
myids=c("PassengerId")
id_col=testset[myids]
newpred=cbind(id_col, pred)
colnames(newpred)=c("Passengerid", "Survived")
write.csv(newpred, file="/Users/byu/Desktop/Data/titanic-J48-pred-05-17-2017.csv", row.names=FALSE)

#80.8%
#Kaggle .78469

model 2: some feature selection

myVars=c("Pclass", "Sex", "Age", "SibSp", "Parch", "Fare", "Survived")
newtrain=trainset[myVars]
newtest=testset[myVars]
m=J48(Survived~., data = newtrain)
m=J48(Survived~., data = newtrain, control=Weka_control(U=FALSE, M=2, C=0.5))
e=evaluate_Weka_classifier(m, seed=1, numFolds=10)
pred=predict (m, newdata = newtest, type = c("class"))
myids=c("PassengerId")
id_col=testset[myids]
newpred=cbind(id_col, pred)
colnames(newpred)=c("Passengerid", "Survived")
View(newpred)
write.csv(newpred, file="/Users/byu/Desktop/Data/titanic-J48-pred-05-17-2017-fs.csv", row.names=FALSE)

#81.7%
#Kaggle .78469

Unit 5 - Decision Tree/RWeka-Titanic (1).r


library('readr')
library('dplyr')
library('ggplot2')
library('forcats')

book_dataset <- read_csv("https://raw.githubusercontent.com/safesit23/INT214-Statistics/main/datasets/prog_book.csv")
glimpse(book_dataset)
View(book_dataset)

is.na(book_dataset)
summary(book_dataset)

book_dataset %>% group_by(Type) %>% summarise(mean_num = mean(Number_Of_Pages)) %>% arrange(desc(mean_num))
book_dataset %>% arrange(desc(Rating)) %>% head(5)
book_dataset %>% arrange(desc(Price)) %>% head(5)
book_dataset %>% group_by(Type) %>% count() %>% arrange(desc(n))
book_dataset %>% group_by(Rating) %>% count() %>% arrange(desc(n))
book_dataset %>% select(Book_title,Rating,Price) %>% filter(Rating > mean(Rating))

ggplot(book_dataset,aes(x=Book_title))
ggplot(book_dataset,aes(x=Rating,y=Price)) + geom_point(aes(color=Type)) + geom_smooth()
ggplot(book_dataset,aes(x=Rating,y=Reviews))+ geom_point()
ggplot(book_dataset,aes(y=Type)) + geom_bar() + coord_flip()

book_dataset %>%
mutate(Type = fct_infreq(Type)) %>%
ggplot(aes(x = Type)) +
geom_bar()


# function to summarize estimation results
summary.PAFit_result <- function(object,...){
    cat("Estimation results by the PAFit method. \n");

     if (object$only_PA == TRUE) {
        cat("Mode: Only the attachment function was estimated. \n")
    } else if (object$only_f == TRUE) {
        cat("Mode: Only node fitnesses were estimated. \n")
    }
    else {
        cat("Mode: Both the attachment function and node fitness were estimated. \n")
    }
    #cat("Form of the PA function:",object$mode_f,"\n");

    if (object$only_f == FALSE) {
        if (object$auto_lambda == TRUE) {
            cat("Selected r parameter:", object$ratio,"\n");
        } else cat("Lambda used:", object$lambda,"\n");
    }
    if (object$only_PA == FALSE)
        cat("Selected s parameter: ",object$shape,"\n", sep = "")
    cat("Estimated attachment exponent:",object$alpha,"\n");
    if (object$ci[1] == "N") {
      cat("No possible confidence interval for the estimated attachment exponent.\n");
    } else if (object$mode_f != "Log_linear") {
      cat("Attachment exponent ","\u00B1", " 2 s.d.", ": (", object$ci[1], ",",
          object$ci[2],")\n",sep = "");
    }
    else {
      cat("Attachment exponent ","\u00B1", " 2 s.d.", ": (", object$ci[1], ",",
          object$ci[2],")\n",sep = "");
    }
    cat("-------------------------------------------\n")
    cat("Additional information: \n");
    cat("Number of bins:", object$g,"\n");
    cat("Number of iterations:",length(object$objective_value) - 1,"\n");
    cat("Stopping condition:", object$stop_cond,"\n");
}


Reading into Eigen vector...
log_omega0_c1       4.4
log_omega0_c2       3.7
log_sd_in_c1        4.6
log_sd_in_c2        2.3
log_zeta            -1.6

Reading into Eigen vector...
omega0              80
sd_in               100
zeta                0.2
sd_obs              0.05

Reading into Eigen vector...
x1                  0
x2                  0

it              lt0             lt_diff         q_diff
0               6161.36         -               -               SDE has stable fixed points for c=0, c_light, c_deep
100             6167.78         1.78954         -0.977668       SDE has stable fixed points for c=0, c_light, c_deep
200             6166.55         -1.33167        1.60726         SDE has stable fixed points for c=0, c_light, c_deep
300             6168.09         3.653           -2.78459        SDE has stable fixed points for c=0, c_light, c_deep
400             6167.77         -3.49439        2.32674         SDE has stable fixed points for c=0, c_light, c_deep
500             6166.76         -0.70371        0.579049        SDE has stable fixed points for c=0, c_light, c_deep
600             6167.87         -2.22505        1.55988         SDE has stable fixed points for c=0, c_light, c_deep
700             6168.79         -3.00297        2.28211         SDE has stable fixed points for c=0, c_light, c_deep
800             6163.34         -2.11933        1.96513         SDE has stable fixed points for c=0, c_light, c_deep
900             6166.06         -2.03601        1.52876         SDE has stable fixed points for c=0, c_light, c_deep
1000            6167.45         0.593896        -0.255235       SDE has stable fixed points for c=0, c_light, c_deep

Acceptance rate : 0.765


###
# calculates the proportion of monolinguals
# among Mongolian speakers in the sample
# across different age cohorts
# and plots as histogram with error bars
# bonus plot: the inverse proportion (bilinguals)
###

rm (list=ls())
library(dplyr)
library(tidyr)
library(ggplot2)

# read in data and remove missing obs
source('inread.r')
df <- inread('data/mbc_everybody.csv')
df <- df[!is.na(df$Profile),]
df <- df[df$Birthyear>1800,]
df <- df[!is.na(df$Birthyear),]

# bin birthyears into cohorts
cohort <- function(x){
          ifelse(x < 1930, "1880-1930",
           ifelse(x < 1940, "1930s",
            ifelse(x < 1950, "1940s",
             ifelse(x < 1960, "1950s",
              ifelse(x < 1970, "1960s",
               ifelse(x < 1980, "1970s",
                ifelse(x < 1990, "1980s",
                 ifelse(x < 2000, "1990s",
                   "2000-2007")))))))) }
df$Cohort <- as.factor(cohort(df$Birthyear))

# set the proper ordering of M, B and C
df$Profile <- factor(df$Profile,
  levels=c("M", "B", "C"), ordered=TRUE)

# get counts of language profile x age cohort
tallies <- as.data.frame(
  tally(na.omit(df) %>%
    group_by(Cohort, Profile))) %>%
  spread(Profile, n)
tallies$PlusM <- tallies$M + tallies$B
tallies$monoRatio <- tallies$M/tallies$PlusM
tallies$biRatio <- tallies$B/tallies$PlusM

# calculate standard error
get.se <- function(df, col, n){
  p <- df[[col]]
  n <- df[[n]]
  x <- sqrt(p*(1-p)/n)
  return(x)
}

tallies$monoSE <- get.se(tallies, "monoRatio", "PlusM")
tallies$biSE <- get.se(tallies, "biRatio", "PlusM")

# save out underlying data from plots
write.csv(tallies,
  file = "analysis/mbc_prop.csv",
  fileEncoding = "UTF-8", row.names = FALSE)

# define labels
N <- paste(
      "N =",
      length(df$Profile[df$Profile %in% c("M", "B")]),
      "(interviewees plus parents/caregivers)")
caption <-
    "Proportion of monolinguals among Mongolian speakers"

# make first plot
prop_m <-
  ggplot(data = tallies, aes(x = Cohort, y = monoRatio)) +
  geom_bar(stat = "identity") +
  ylim(0,1) +
  geom_errorbar(aes(ymin=monoRatio-monoSE, ymax=monoRatio+monoSE),
                width=.5, size=0.8) +
  labs(title = paste(caption, N, sep="\n"),
        x = "Decade of Birth",
        y = "Proportion of monolinguals") +
  theme(axis.text=element_text(size=12))

# redefine labels
N <- paste(
      "N =",
      length(df$Profile[df$Profile %in% c("M", "B")]),
      "(interviewees plus parents/caregivers)")
caption <-
    "Proportion of Mongolian-Chinese bilinguals\namong Mongolian speakers"

# make second plot
prop_b <- ggplot(data = tallies, aes(x = Cohort, y = biRatio)) +
  geom_bar(stat = "identity") +
  ylim(0,1) +
  geom_errorbar(aes(ymin=biRatio-biSE, ymax=biRatio+biSE),
                width=.5, size=0.8) +
  labs(title = paste(caption, N, sep="\n"),
        x = "Decade of Birth",
        y = "Proportion of bilinguals")

# save plots
plots <- c("prop_m","prop_b")
prefix <- "figures/mbc_"
l <- mget(plots)
invisible(mapply(ggsave,
  file=paste0(prefix, names(l), ".pdf"),
  width=7.5, height=5, units="in",
  plot=l))
invisible(mapply(ggsave,
  file=paste0(prefix, names(l), ".jpg"),
  width=7.5, height=5, units="in",
  plot=l))


require(rms)
require(mice)
set.seed(1)
n <- 50
d <- data.frame(x1=runif(n), x2=sample(c('a','b','c'), n, TRUE),
                x3=sample(c('A','B','C','D'), n, TRUE),
                x4=sample(0:1, n, TRUE),
                y=runif(n))
d$x1[1:5]  <- NA
d$x2[3:9]  <- NA
d$x3[7:14] <- NA

a <- aregImpute(~ x1 + x2 + x3 + x4 + y, data=d)
ols(y ~ x1 + x2 + x3 + x4, data=d)

fit.mult.impute(y ~ x1 + x2 + x3 + x4, ols, a, data=d)  # works

m <- mice(d)
d1 <- complete(m, 1)
## ols(y ~ x1 + x2 + x3 + x4, data=d1)  # fails

w <- d1
attr(w$x2, 'contrasts') <- NULL
attr(w$x3, 'contrasts') <- NULL
ols(y ~ x1 + x2 + x3 + x4, data=w)   # works

fit.mult.impute(y ~ x1 + x2 + x3 + x4, ols, m, data=d)


library(data.table)
library(arm)
library(stargazer)
source('../config.r')
source('../utils.r')
source('../read_data.r')

extra_path <- file.path('inputs')

get_family_model <- function(DT_family)
  {
    mod <- lm(scale(value) ~            # y
              scale(age_pred) +         # brain age
              scale(age) +              # age
              scale(FI_pred) +          # Fluid Intelligence
              scale(FI) +               # Fluid Intelligence
              scale(N_pred) +
              scale(N),
              DT_family)                     # Neuroticism
    mod
}

get_coefs <- function(mod, coef_names)
{
    coefs <- t(coef(summary(mod)))
    out <- coefs[, coef_names]
    out <- t(out)[, c('Estimate', 'Std. Error', 'Pr(>|t|)')]
    out <- data.frame(out)
    names(out) <- c('coef', 'se', 'p.val')
    out
}

get_bootstrap <- function(mod, coef_names, n.sim = 10000)
{
    mod.sim <- arm::sim(mod, n.sim = n.sim)
    out <- data.table(mod.sim@coef)

    has_scale <- all(sapply(coef_names, function(s) startsWith(s, "scale(")))
    if (has_scale)
    {
      out_names <- gsub("scale(", "", coef_names, fixed = T)
      out_names <- gsub(".{1}$", "", out_names)
    } else {
      out_names <- coef_names
    }

    data.table(
      name = rep(out_names, each = n.sim),
      coef = do.call(c, lapply(coef_names, function(name) out[[name]])))
}

fname <-
  'post_predictive_analysis_all_models_combined_imaging_non_imaging.csv'

DT_pred <- assemble_inputs(fname, path1 = extra_path)[
  evaluation == "Generalization"
]

split_dt <- split(DT_pred, DT_pred$family)
mod_list <- vector(mode = "list", length = length(split_dt))
bs_list <- vector(mode = "list", length = length(split_dt))

for (ii in 1:length(split_dt))
{
  mod <- get_family_model(split_dt[[ii]])
  mod_list[[ii]] <- mod
  coef_names <- names(coef(mod))[-1]
  mod_bs <- get_bootstrap(mod, coef_names)
  mod_bs$family <- names(split_dt)[[ii]]
  bs_list[[ii]] <- mod_bs
}

dt_bs <- rbindlist(bs_list)

target_map <- setNames(
  c('age', 'age', 'FI', 'FI', 'N', 'N'),
  c('age_pred', 'age', 'FI_pred', 'FI', 'N', 'N_pred'))

dt_bs$target <- as.factor(target_map[dt_bs$name])
dt_bs$type <- "proxy"
dt_bs[!endsWith(name, "_pred"), type := "target"]
dt_bs$type <- factor(dt_bs$type, levels=c("target", "proxy"))

this_colors <- with(color_cats, c(orange, `blueish green`, blue))

family_levels <- rev(c("Smoking", "Sleep", "Activity", "Alcohol"))
family_labels <- rev(c(
  "# cigarettes \n smoked\n(pack-years)",
  "sleep \nduration \n(hours)",
  "metabolic \nequivalent task \n(minutes/week)",
  "# alcoholic \nbeverages"
))
dt_bs$family <- factor(
  dt_bs$family, levels = family_levels, labels = family_labels)

dt_bs$target <- factor(dt_bs$target, levels = c("age", "FI", "N"),
                       labels = c("Age", "Fluid Intelligence", "Neuroticism"))

fwrite(dt_bs, 'mod24_cond_big.csv')

col_names <-  c("predicted Age", "Age",
                "predicted Fluid Intelligence", "Fluid Intelligrence",
                "predicted Neuroticism", "Neuroticism")

# reorder models to be in line with the figure
mod_list_out <- mod_list[c(2, 1, 3, 4)]
table <- stargazer(mod_list_out, summary = T,
                   dep.var.caption = "Health-related Habits",
                   dep.var.labels.include = F,
                   column.labels = names(mod_list_out),
                   covariate.labels = col_names)

writeLines(table, "big_models_inference.tex")

vif_results <- do.call(data.frame, lapply(mod_list_out, function(x) car::vif(x)))
rownames(vif_results) <- col_names
writeLines(stargazer(vif_results, summary = F), "big_models_vifs.tex")


cat(sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  n <- 0
  k <- 0
  st <- sapply(strsplit(s, "")[[1]], function(t) {
    n <<- n + 1
    if (t == "$") {
      k <<- n
    }
    utf8ToInt(t) * 2048 + n
  })
  st <- st[order(st)]
  r <- c()
  for (i in 1:(n-1)) {
    r[i] <- intToUtf8(st[k] / 2048)
    k <- st[k] %% 2048
  }
  paste(r, collapse="")
}), sep="\n")


sum <- function(var, lo, hi, term)
  eval(substitute({
    .temp <- 0;
    for (var in lo:hi) {
      .temp <- .temp + term
    }
    .temp
  }, as.list(match.call()[-1])),
  enclos=parent.frame())

sum(i, 1, 100, 1/i) #prints 5.187378

##and because of enclos=parent.frame(), the term can involve variables in the caller's scope:
x <- -1
sum(i, 1, 100, i^x) #5.187378


#' Plot expected spawnings
#'
#' Plot expected number of spawnings as a function of fishing mortality rate.
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param nyrs.ave number of years to average for calculating Reference Points
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotExpSpawn <- function(asap,a1,nyrs.ave,save.plots,od,plotf){

  nages<- asap$parms$nages
  nyears <- asap$parms$nyears
  if (asap$options$isfecund == 1){
    fec.age <- rep(1, nages)
  }else{
    fec.age <- apply(asap$WAA.mats$WAA.ssb[(nyears-nyrs.ave+1):nyears,],2,mean)
  }
  mat.age <- apply(asap$maturity[(nyears-nyrs.ave+1):nyears,],2,mean)
  wgt.age <- apply(asap$WAA.mats$WAA.catch.all[(nyears-nyrs.ave+1):nyears,],2,mean)
  M.age <- apply(asap$M.age[(nyears-nyrs.ave+1):nyears,],2,mean)
  sel.mat <- asap$F.age[(nyears-nyrs.ave+1):nyears,]/apply(asap$F.age[(nyears-nyrs.ave+1):nyears,],1,max)
  sel.age<- apply(sel.mat,2,mean)
  spawn.time <- asap$options$frac.yr.spawn

  F.range <- seq(0,2.0, by=0.01)
  nF <- length(F.range)
  exp.spawn.vec <- rep(0, nF)
  spr.vec <- rep(0, nF)

  spr0<- s.per.recr(nages=nages, fec.age=fec.age, mat.age=mat.age, M.age= M.age, F.mult=0, sel.age=sel.age, spawn.time=spawn.time)
  spawn0<- s.per.recr(nages=nages, fec.age=rep(1,nages), mat.age=mat.age, M.age= M.age, F.mult=0, sel.age=sel.age, spawn.time=spawn.time)
  # plot maturity vs selectivity based on "nyrs.ave" average

  par(mfrow=c(1,1), mar=c(4,4,2,4) )
  plot( seq(1,nages), mat.age, type='l', col='black', lwd=2, ylim=c(0,1.1),
        xlab="Age", ylab="Selectivity or Maturity at age")
  lines( seq(1,nages), sel.age, col='orange2', lwd=1)
  points( seq(1,nages), sel.age, col='orange2', pch=16)
  legend('topleft', legend=c("Maturity", "Selectivity"), col=c("black", "orange2"),
         lwd=c(2,1), pch=c(NA, 16) )
  if (save.plots) savePlot(paste0(od, "Selectivity.vs.Maturity.", plotf), type=plotf)

  for(j in 1:nF) {

    spawn.per.recr = s.per.recr(nages=nages, fec.age=fec.age, mat.age=mat.age, M.age= M.age, F.mult=F.range[j], sel.age=sel.age, spawn.time=spawn.time)
    spr.vec[j] = spawn.per.recr/spr0
    exp.spawn =  s.per.recr(nages=nages, fec.age=rep(1,nages), mat.age=mat.age, M.age= M.age, F.mult=F.range[j], sel.age=sel.age, spawn.time=spawn.time)
    #exp.spawn.vec[j] = exp.spawn/spawn0
    exp.spawn.vec[j] = exp.spawn
  } # end loop over F

  par(mfrow=c(1,1), mar=c(4,4,2,4) )

  plot(F.range, exp.spawn.vec, type='n', xlab="Full F", ylab="Expected Spawnings", lwd=2,
       col="skyblue3", ylim=c(0,1.2*max(exp.spawn.vec)))
  abline(v=seq(0.1,2.0, by=0.1), col="grey85")
  abline(h=c(1,2,3), col="skyblue1")
  lines(F.range, exp.spawn.vec, lwd=2, col="skyblue3" )
  points(F.range, exp.spawn.vec, pch=19, col="skyblue3" )
  scale.spr.vec <- max(spr.vec)/max(exp.spawn.vec)

  lines(F.range, spr.vec/scale.spr.vec, col="red", lwd=2 )
  axis(side=4, at=seq(0,1,by=0.1)/scale.spr.vec, lab=seq(0,1,by=0.1), las=2,
       col='black', col.axis="black")
  mtext(side=4, "% SPR", line=3, col="red")
  title (paste0("Expected Spawnings and SPR Reference Points (Years Avg = ", nyrs.ave,")"), cex=0.9, outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Exp.Spawn.SPR.Curves.", plotf), type=plotf)

  exp.spawn.table <- as.data.frame(matrix(NA, nrow=nF, ncol=3) )
  exp.spawn.table[,1] <- F.range
  exp.spawn.table[,2] <- exp.spawn.vec
  exp.spawn.table[,3] <- spr.vec

  par(mfrow=c(1,1), mar=c(2,2,2,2))
  plot(seq(1,42), seq(-3,38), type='n', axes=F, bty='n',xlab="",ylab="")

  text(x=0,y=36, labels="F", font=2, pos=4)
  text(x=4, y=36, labels="E[Sp]" , font=2, pos=4,cex=0.9)
  text(x=9, y=36, labels="SPR", font=2, pos=4 )

  text(x=15,y=36, labels="F", font=2, pos=4)
  text(x=19, y=36, labels="E[Sp]" , font=2, pos=4,cex=0.9)
  text(x=24, y=36, labels="SPR", font=2, pos=4 )

  text(x=30,y=36, labels="F", font=2, pos=4)
  text(x=34, y=36, labels="E[Sp]" , font=2, pos=4,cex=0.9)
  text(x=39, y=36, labels="SPR", font=2, pos=4 )

  for (i in 1:35) {
    text(x=0, y=seq(35,1, by=-1), labels=F.range[1:35], cex=0.82, pos=4, font=1 )
    text(x=4, y=seq(35,1, by=-1), labels=round(exp.spawn.vec[1:35],4), cex=0.82, pos=4, font=1 )
    text(x=9, y=seq(35,1, by=-1), labels=round(spr.vec[1:35],4), cex=0.82, pos=4, font=1 )
  }
  for (i in 36:70) {
    text(x=15, y=seq(35,1, by=-1), labels=F.range[36:70], cex=0.82, pos=4, font=1)
    text(x=19, y=seq(35,1, by=-1), labels=round(exp.spawn.vec[36:70],4), cex=0.82, pos=4, font=1)
    text(x=24, y=seq(35,1, by=-1), labels=round(spr.vec[36:70],4), cex=0.82, pos=4, font=1)
  }
  for (i in 71:105) {
    text(x=30, y=seq(35,1, by=-1), labels=F.range[71:105], cex=0.82, pos=4, font=1)
    text(x=34, y=seq(35,1, by=-1), labels=round(exp.spawn.vec[71:105],4), cex=0.82, pos=4, font=1)
    text(x=39, y=seq(35,1, by=-1), labels=round(spr.vec[71:105],4), cex=0.82, pos=4, font=1)
  }
  title (paste0("Expected Spawnings & SPR Reference Points (Years Avg = ", nyrs.ave,")"), cex=0.9, outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "Exp.Spawn.SPR.Table.", plotf), type=plotf)

  frep1 <-asap$options$Freport.agemin
  frep2 <-asap$options$Freport.agemax
  if (frep1==frep2) freport <-F.range*sel.age[frep1:frep2]
  if (frep2>frep1) freport <-F.range*mean(sel.age[frep1:frep2])

  asap.name <- a1$asap.name

  exp.spawn.table<- as.data.frame(cbind(F.range, exp.spawn.vec, spr.vec, freport))
  colnames(exp.spawn.table) <- c("Full.F", "Exp.Spawn", "SPR", paste0("Freport_",frep1,"-",frep2))
  write.csv( exp.spawn.table, file=paste0(od,"Exp.Spawn.Table_",asap.name,".csv"), row.names=F )

  return()
} # end function