# -------------------------------------------
#  App Title: Benford's Law and Data Examples
#     Author: Jimmy Doi
# -------------------------------------------

library(RColorBrewer)
library(rvest)
library(xml2)

shinyUI(navbarPage("Benford's Law: Data Examples",

  #open tabPanel#1
  #############################################################################
  ## tabPanel: Census Data I                                                 ##
  #############################################################################
  tabPanel("(1) Census Data I",
    fluidPage(
     tags$head(tags$link(rel = "icon", type = "image/x-icon", href = "https://webresource.its.calpoly.edu/cpwebtemplate/5.0.1/common/images_html/favicon.ico")),

    # Give the page a title
    h3("(1) Benford's Law: US Census Data I",HTML("–"),"Population Estimates"),

    div("Note: Please adjust width of browser if only one column is visible.",br(),
        HTML("[Click here for another Shiny app on Benford's Law]"),
        style = "font-size: 9pt;color:teal"),br(),

    p("The first-digit distribution of many US Census variables is known to closely follow",
      HTML("Benford's Law."),
    "We will consider several census variables available from",
     HTML("
          County Totals Dataset: Population, Population Change and Estimated
          Components of Population Change."),
     "The app will apply a goodness of fit test of the observed frequencies of first-digits
     for the selected variable. The variables under consideration are: Annual Resident Total Population
     Estimate (2013 to 2016), Annual Births (2013 to 2016), Annual Deaths (2013 to 2016)."),

    p("Note: It may be the case that some variables do not sufficiently adhere
    to Benford's Law according to the goodness of fit test.
    However bear in mind that relatively small deviations from what is expected
    can lead to a small P-value for the test due to a large sample size. Nevertheless,
    it is still interesting to see that, for any census variable from this app, the observed
    proportions of first-digits are not uniformly equal to 1/9 as one might expect and that Benford's
    Law can at least serve as a rough approximation."),

    HTML("
"),

    # Generate a row with a sidebar
    fluidRow(
      column(4,wellPanel(

        selectInput("sel.var.cens", label = h5("Select Census Variable:"),
                    choices = list("Population Est. 2016" = 16,
                                   "Population Est. 2015" = 15,
                                   "Population Est. 2014" = 14,
                                   "Population Est. 2013" = 13,
                                   "Births, 2016" = 30,
                                   "Births, 2015" = 29,
                                   "Births, 2014" = 28,
                                   "Births, 2013" = 27,
                                   "Deaths, 2016" = 37,
                                   "Deaths, 2015" = 36,
                                   "Deaths, 2014" = 35,
                                   "Deaths, 2013" = 34
                                   ),
                    selected = 16),

        br(), br(), br(), br(),

        div("Shiny app by", a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
        "Jimmy Doi"),align="right", style = "font-size: 8pt"),

        div("Base R code by", a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
        "Jimmy Doi"),align="right", style = "font-size: 8pt"),

        div("Shiny source files:", a(href="https://gist.github.com/calpolystat/94fe941ab0d8a4f36d8b",
        target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),

        div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
        "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt")
          ) # Close wellPanel
        ), # Close column-4

      column(8,
        div(span("Data from:",style="text-align:
            right;font-size:11pt;display:inline-block"),
        HTML("
          County Totals Dataset"),
        style="font-size:11pt;"),

        div(span("Total Number of Counties in Data Set: ",style="text-align:
                  right;font-size:11pt;display:inline-block"),
            span(textOutput("comp.rows.cens"),style="text-align: right;font-size:11pt;
                 display:inline-block;color:#5C8AE6;font-weight:normal")),

        div(span("Census Variable: ",style="text-align:
            right;font-size:11pt;display:inline-block"),
            span(textOutput("out.var.cens"),style="text-align: right;font-size:11pt;
            display:inline-block;color:#5C8AE6;font-weight:normal")
            ),

        HTML("
"),

        fluidRow(
          column(4,
           p(tags$b("Goodness of Fit Test:")),
           verbatimTextOutput("goodness.cens")
           ),
          column(8,
            plotOutput("cens.pmf")
            )#closes column-8
           ),#closes fluidRow
          HTML("
")
     ) #closes column-8
    ) #closes fluidRow
   ) #closes fluidPage
  ), #close tabPanel#1

  #open tabPanel#2
  #############################################################################
  ## tabPanel: Census Data II                                                ##
  #############################################################################
  tabPanel("(2) Census Data II",
    fluidPage(

    # Give the page a title
    h3("(2) Benford's Law: US Census Data II",HTML("–"),"QuickFacts"),

    div("Note: Please adjust width of browser if only one column is visible.",br(),
        HTML("[Click here for another Shiny app on Benford's Law]"),
        style = "font-size: 9pt;color:teal"),br(),

    p("The first-digit distribution of many US Census variables is known to closely follow",
      HTML("Benford's Law."),
    "We will consider several census variables available from",
     HTML("US Census State & County QuickFacts."),
     "The app will apply a goodness of fit test of the observed frequencies of first-digits
     for the selected variable. The variables under consideration are:
      Housing Units (2013),
      Households (2008-12),
      Veterans (2008-12),
      Nonemployer Establishments (2012),
      *Private Nonfarm Establishments (2012),
      *Private Nonfarm Employment (2012),
      *Retail Sales (2007)."),

    p("*A small fraction (less than 2%) of the 3143 counties had entries of
        zero for the variables listed with an asterisk. For these cases, only the non-zero
        values were used for the goodness of fit test.",style="font-style:normal;font-size:9pt"),

    p("Note: It may be the case that some variables do not sufficiently adhere
    to Benford's Law according to the goodness of fit test.
    However bear in mind that relatively small deviations from what is expected
    can lead to a small P-value for the test due to a large sample size. Nevertheless,
    it is still interesting to see that, for any census variable from this app, the observed
    proportions of first-digits are not uniformly equal to 1/9 as one might expect and that Benford's
    Law can at least serve as a rough approximation."),

    HTML("
"),

    # Generate a row with a sidebar
    fluidRow(
      column(4,wellPanel(

        selectInput("sel.var.quick", label = h5("Select Census Variable:"),
                    choices = list("Housing Units, 2013" = 25,
                                   "Households, 2008-12" = 29,
                                   "Veterans, 2008-12" = 23,
                                   "Nonemployer Est., 2012" = 37,
                                   "*Private Nonfarm Est., 2012" = 34,
                                   "*Private Nonfarm Emp., 2012" = 35,
                                   "*Retail Sales, 2007 ($1000)" = 47),
                    selected = 25),

        br(), br(), br(), br(),

        div("Shiny app by", a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
        "Jimmy Doi"),align="right", style = "font-size: 8pt"),

        div("Base R code by", a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
        "Jimmy Doi"),align="right", style = "font-size: 8pt"),

        div("Shiny source files:", a(href="https://gist.github.com/calpolystat/94fe941ab0d8a4f36d8b",
        target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),

        div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
        "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt")
          ) # Close wellPanel
        ), # Close column-4

      column(8,
        div(span("Data from:",style="text-align:
            right;font-size:11pt;display:inline-block"),
            HTML("US Census State & County QuickFacts"),
            style="font-size:11pt;"),

        div(span("Total Number of Counties in Data Set: ",style="text-align:
                  right;font-size:11pt;display:inline-block"),
            span(textOutput("comp.rows.quick"),style="text-align: right;font-size:11pt;
                 display:inline-block;color:#5C8AE6;font-weight:normal")),

        div(span("Census Variable: ",style="text-align:
            right;font-size:11pt;display:inline-block"),
            span(textOutput("out.var.quick"),style="text-align: right;font-size:11pt;
            display:inline-block;color:#5C8AE6;font-weight:normal")
            ),

        HTML("
"),

        fluidRow(
          column(4,
           p(tags$b("Goodness of Fit Test:")),
           verbatimTextOutput("goodness.quick")
           ),
          column(8,
            plotOutput("quick.pmf")
            )#closes column-8
           ),#closes fluidRow
          HTML("
")
     ) #closes column-8
    ) #closes fluidRow
   ) #closes fluidPage
  ), #close tabPanel#2

  #open tabPanel#3
  #############################################################################
  ## tabPanel: Stock Exchange                                                ##
  #############################################################################
  tabPanel("(3) US Stock Markets",
           fluidPage(

             # Give the page a title
             h3("(3) Benford's Law: US Stock Markets"),

             div("Note: Please adjust width of browser if only one column is visible.",
                 style = "font-size: 9pt;color:teal"),br(),

             p("After a given day of trading, if we consider the first-digit of the
               volume of shares traded for each listed company in the New York Stock Exchange,
               the corresponding distribution will closely follow",
               HTML("Benford's Law."),
               "Does the first-digit distribution for other variables such as a stock's closing cost
               closely follow Benford's Law? And does the specific stock market have any influence on the
               first-digit distribution of market variables?"),

             p("This app will download information from the",
               span(HTML("Wall Street Journal website")),
               "from the",span("most recent end of day market data.",style="font-weight:bold"),
               "The data will be based on various
               market variables for all
               companies listed in one of four stock markets.
               The app will apply a goodness of fit test of the observed frequencies of first-digits
               for the selected variable in the specified stock market."),

             p("Note: It may be the case that some stock price variables do not sufficiently adhere
               to Benford's Law according to the goodness of fit test.
               However bear in mind that relatively small deviations from what is expected
               can lead to a small P-value for the test due to a large sample size. Nevertheless,
               it is still interesting to see that, for any variable in this app, the observed
               proportions of first-digits are not uniformly equal to 1/9 as one might expect and that Benford's
               Law can at least serve as a rough approximation."),

             HTML("
"),

             # Generate a row with a sidebar
             fluidRow(
               column(4,wellPanel(

                 selectInput("stock", label = h5("Select Stock Market:"),
                             choices = c("New York Stock Exchange",
                                         "Nasdaq Stock Market",
                                         "Nasdaq Capital Market",
                                         "NYSE MKT Stock Exchange"),
                             selected = "New York Stock Exchange"), br(),

                 selectInput("sel.var", label = h5("Select Variable"),
                             choices = list("Volume of Shares Traded" = 9,
                                            "Opening Price" = 3,
                                            "High Price" = 4,
                                            "Low Price" = 5,
                                            "Closing Price" = 6),
                             selected = 9),

                 br(), br(), br(), br(),

                 div("Shiny app by", a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
                                       "Jimmy Doi"),align="right", style = "font-size: 8pt"),

                 div("Base R code by", a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
                                         "Jimmy Doi"),align="right", style = "font-size: 8pt"),

                 div("Shiny source files:", a(href="https://gist.github.com/calpolystat/f4475cbfe4cc77cef168",
                                              target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),

                 div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
                       "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt")
               ) # Close wellPanel
               ), # Close column-4

               column(8,

                      div(span(imageOutput("USA.icon.stock",height=24),style="vertical-align: middle;display:inline-block"),
                          span(HTML(" Currency:"),style="text-align:left;
                               font-size:11pt;vertical-align: middle;display:inline-block"),
                          span(HTML(" "),style="text-align:left;font-size:11pt;vertical-align: middle;display:inline-block"),
                          span(textOutput("USA.curr.stock"),style="text-align:left;font-size:11pt;color:#5C8AE6;
                               display:inline-block;vertical-align: middle"),
                          span(HTML("         "),style="text-align: right;vertical-align: middle;font-size:11pt"),
                      span("End of Day Market Data from: ",style="text-align:
                      right;font-size:11pt;vertical-align: middle;display:inline-block"),
                          span(HTML(" "),style="text-align: right;vertical-align: middle;font-size:11pt"),
                          span(textOutput("comp.date"),style="text-align: right;vertical-align: middle;font-size:11pt;
                      display:inline-block;color:#5C8AE6;font-weight:normal"),
                          style="text-align: right;font-size:0pt;display:inline-block;"),br(),

                      div(span("Market Source: ",style="text-align:
                      right;font-size:11pt;display:inline-block"),
                          span(textOutput("short.stock"),style="text-align: right;font-size:11pt;
                     display:inline-block;color:#5C8AE6;font-weight:normal"),
                          span(HTML("    "),style="text-align: right;font-size:11pt"),
                          span("Total Number of Stocks in Data Set: ",style="text-align:
                      right;font-size:11pt;display:inline-block"),
                          span(textOutput("comp.rows"),style="text-align: right;font-size:11pt;
                     display:inline-block;color:#5C8AE6;font-weight:normal")),

                      HTML("
"),

                      fluidRow(
                        column(4,
                               p(tags$b("Goodness of Fit Test:")),
                               div(span(textOutput("out.var"),style="text-align: right;font-size:11pt;
                      display:inline-block;color:#5C8AE6;font-weight:normal;text-align: center")),
                               br(),
                               verbatimTextOutput("goodness")
                        ),
                        column(8,
                               plotOutput("stock.pmf")
                        )#closes column-8
                      ),#closes fluidRow
                      HTML("
")
               ) #closes column-8
             ) #closes fluidRow
             ) #closes fluidPage
               ), #close tabPanel#3

  #open tabPanel#4
  #############################################################################
  ## tabPanel: World Stock Exchange                                          ##
  #############################################################################
  tabPanel("(4) World Stock Markets",
           fluidPage(

             # Give the page a title
             h3("(4) Benford's Law: World Stock Markets"),

             div("Note: Please adjust width of browser if only one column is visible.",br(),
                 HTML("[Click here for another Shiny app on Benford's Law]"),
                 style = "font-size: 9pt;color:teal"),br(),

             p("For the New York Stock Exchange (see previous tab),
              we found that the first-digit distribution of stock prices
              closely follows",
               HTML("Benford's Law."),
               "Does Benford's Law also apply to the first-digit distribution for stock prices from other world markets?
               Does currency have any influence on the
               first-digit distribution of market variables?"),

             p("This app will download market data from the",
               span(HTML("Investing.com website. ")),
               "For the selected stock market, if trading is ", span("active ",style="font-weight:bold"),
               "at the point of data access,
                the results will be based on the ", span("most current market data.",style="font-weight:bold"),
               "If the market is closed at point of access, then all information will be based on the most recent
                end of day market data. The app will apply a goodness of fit test of the observed frequencies of first-digits
               for the selected variable in the specified stock market."),

             p("Note: It may be the case that some stock price variables do not sufficiently adhere
               to Benford's Law according to the goodness of fit test.
               However bear in mind that relatively small deviations from what is expected
               can lead to a small P-value for the test due to a large sample size. Nevertheless,
               it is still interesting to see that, for any variable in this app, the observed
               proportions of first-digits are not uniformly equal to 1/9 as one might expect and that Benford's
               Law can at least serve as a rough approximation."),

             HTML("
"),

             # Generate a row with a sidebar
             fluidRow(
               column(4,wellPanel(

                 selectInput("w.stock", label = h5("Select World Market:"),
                             choices = c("Australia",
                                         "Canada",
                                         "China",
                                         "Denmark",
                                         "England",
                                         "France",
                                         "Germany",
                                         "India",
                                         "Japan",
                                         "Korea",
                                         "Netherlands",
                                         "Poland",
                                         "Sri Lanka",
                                         "Switzerland",
                                         "Turkey"),
                             selected = "Australia"), br(),

                 selectInput("w.sel.var", label = h5("Select Variable:"),
                             choices = list("Most Recent Price" = 3,
                                            "High Price" = 4,
                                            "Low Price" = 5),
                             selected = 3),

                 br(), br(), br(), br(),

                 div("Shiny app by", a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
                                       "Jimmy Doi"),align="right", style = "font-size: 8pt"),

                 div("Base R code by", a(href="http://statweb.calpoly.edu/jdoi/",target="_blank",
                                         "Jimmy Doi"),align="right", style = "font-size: 8pt"),

                 div("Shiny source files:", a(href="https://gist.github.com/calpolystat/94fe941ab0d8a4f36d8b",
                                              target="_blank","GitHub Gist"),align="right", style = "font-size: 8pt"),

                 div(a(href="http://www.statistics.calpoly.edu/shiny",target="_blank",
                       "Cal Poly Statistics Dept Shiny Series"),align="right", style = "font-size: 8pt")
               ) # Close wellPanel
               ), # Close column-4

               column(8,

                      div(span(imageOutput("w.icon.stock",height=24),style="vertical-align: middle;display:inline-block"),
                          span(HTML(" Currency:"),style="text-align:left;
                               font-size:11pt;vertical-align: middle;display:inline-block"),
                          span(HTML(" "),style="text-align:left;font-size:11pt;vertical-align: middle;display:inline-block"),
                          span(textOutput("w.curr.stock"),style="text-align:left;font-size:11pt;color:#5C8AE6;
                               display:inline-block;vertical-align: middle"),
                          span(HTML("          "),
                               style="text-align: left;font-size:11pt;vertical-align: middle"),
                          span("Access Point: ",style="text-align:
                               left;font-size:11pt;display:inline-block;vertical-align: middle"),
                          span(HTML(" "),style="text-align: left;font-size:11pt"),
                          span(textOutput("w.time.stock"),style="text-align: left;font-size:11pt;
                               display:inline-block;color:#5C8AE6;font-weight:normal;vertical-align: middle"),
                          style="text-align: right;font-size:0pt;display:inline-block;"),br(),

                      div(span("Market Status:",style="text-align:
                               left;font-size:11pt;display:inline-block;vertical-align: middle"),
                          span(textOutput("w.mkt.status"),style="text-align: left;font-size:11pt;
                               display:inline-block;color:red;font-weight:normal;vertical-align: middle"),
                          span(HTML("    "),style="text-align: left;font-size:11pt;vertical-align: middle"),
                          span("Source: ",style="text-align:
                               left;font-size:11pt;display:inline-block;vertical-align: middle"),
                          span(textOutput("w.short.stock"),style="text-align: left;font-size:11pt;
                               display:inline-block;color:#5C8AE6;font-weight:normal;vertical-align: middle"),
                          span(HTML("    "),style="text-align: left;font-size:11pt;vertical-align: middle"),
                          span("Total Stocks: ",style="text-align:
                               left;font-size:11pt;display:inline-block;vertical-align: middle"),
                          span(textOutput("w.comp.rows"),style="text-align: left;font-size:11pt;
                          display:inline-block;color:#5C8AE6;font-weight:normal;vertical-align: middle")
                          ),

                      HTML("
"),

                      fluidRow(
                        column(4,
                               p(tags$b("Goodness of Fit Test:")),
                               div(span(textOutput("w.out.var"),style="text-align: right;font-size:11pt;
                                        display:inline-block;color:#5C8AE6;font-weight:normal;text-align: center")),
                               br(),
                               verbatimTextOutput("w.goodness")
                               ),
                        column(8,
                               plotOutput("w.stock.pmf")
                        )#closes column-8
                      ),#closes fluidRow
                      HTML("
")
                          ) #closes column-8
                      ) #closes fluidRow
             ) #closes fluidPage
               ) #close tabPanel#4

  ) #closes navbarPage
) #closes shinyUI


#!/sw/math/R-2.15.3-shlib/bin/Rscript

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# NOTE: since picante is licensed under the GPL, and this program relies on
# picante, the program is licensed under the GPL regardless
#
# See: http://cran.r-project.org/web/packages/picante/picante.pdf,
# http://www.gnu.org/licenses/old-licenses/gpl-2.0-faq.html#IfLibraryIsGPL
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

library('picante')

args <- commandArgs(trailingOnly = TRUE)

sample <- read.table(file = args[1])
tree <- read.tree(file = args[2])

# get community data matrix of sample
comm <- sample2matrix(sample)
# get phylogenetic distance matrix of tree
phydist <- cophenetic(tree)

# finally, run the processed info through ses.mpd to get the result we want
result <- ses.mpd(comm, phydist)

# capture result and output to file
out <- capture.output(result)
cat(out, file = args[3], sep = "\n")


subroutine delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,nerror)

# Output the endpoints of the line segments joining the
# vertices of the Delaunay triangles.
# Called by master.

implicit double precision(a-h,o-z)
logical value
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
dimension delsgs(6,ndel)

# For each distinct pair of points i and j, if they are adjacent
# then put their endpoints into the output array.
npd = ntot-4
kseg = 0
do i = 2,npd {
        do j = 1,i-1 {
                call adjchk(i,j,value,nadj,madj,ntot,nerror)
		if(nerror>0){
                    return
                }
                if(value) {
			kseg = kseg+1
			if(kseg > ndel) {
				nerror = 14
				return
			}
			delsgs(1,kseg) = x(i)
			delsgs(2,kseg) = y(i)
			delsgs(3,kseg) = x(j)
			delsgs(4,kseg) = y(j)
			delsgs(5,kseg) = i
			delsgs(6,kseg) = j
                }
        }
}
ndel = kseg

return
end


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), ","), function(s) {
  n <- as.integer(s[1])
  m <- as.integer(s[2])
  n - as.integer(n / m) * m
}), sep="\n")


#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：diameter_stable ,  电压区间与三种液体之间随流量、极间距离、针头直径变化的影响

######################读取文件模块###################
#setwd("D:/data")
library(xlsx)

#读取v~h的数据
de_r<-read.xlsx("voltage.xls",sheetName="ethanol_r", header=TRUE)
da_r<-read.xlsx("voltage.xls",sheetName="acetone_r", header=TRUE)
di_r<-read.xlsx("voltage.xls",sheetName="iso_r", header=TRUE)

#保存pdf
pdf("diameter_3liquids_stable.pdf")
#画图-乙醇

plot(de_r$radius, de_r$stable,  col=0, xaxs="i", xlim=c(0.2, 0.9), ylim=c(0.6, 1.3),
xlab="OD(mm)", cex.lab=1.1, mgp=c(1, 0, 0),
tck=0.02,
ylab=expression(V["stable"](kv)))

title(main="Vollage range changes with diameter",line=0.5,cex.main=1.1)

model_esv <- loess(de_r$stable ~ de_r$radius)
fit <- fitted(model_esv)
ord <- order(de_r$radius)

lines(de_r$radius[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2) # 乙醇的拟合曲线

#画图-丙酮
#points(da_r$radius, da_r$stable,  pch=23, col="blue")

model_asv <- loess(da_r$stable ~ da_r$radius)
fit <- fitted(model_asv)
ord <- order(da_r$radius)

lines(da_r$radius[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2) # 丙酮的拟合曲线

#画图-异丙醇
#points(di_r$radius, di_r$stable,  pch=23, col="green")

model_isv <- loess(di_r$stable ~ di_r$radius)
fit <- fitted(model_isv)
ord <- order(di_r$radius)

lines(di_r$radius[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2) # 异丙醇的拟合曲线

#图例标注
legend("bottomright", bty="n",
       c("Ethanol", "Acetone", "Isoproply"),
       inset=.1,  pch=c(6, 23, 24),
       col=c("red", "blue", "darkgreen"), lty=2,
       lwd=2.5, cex=1)

dev.off()


#### Functions for Pseudotime analysis

# Run Diffusion map with library("destiny")
# Original code from Stévant I et.al. Cell Rep. 2019.
run_diffMap <- function(data=data, condition=condition, sigma="local", k = 20){
    destinyObj <- as.ExpressionSet(as.data.frame(t(data)))
    destinyObj$condition <- factor(condition)
    dm <- DiffusionMap(destinyObj, sigma, k)
    return(dm)
}

plot_eigenVal <- function(dm=dm){
    linepad <- .5
    plot(
    eigenvalues(dm),
    ylim = 0:1,
    pch = 20,
    xlab ='Diffusion component (DC)',
    ylab ='Eigenvalue'
    )
}

# Lineage prediction with library("slingshot")
# Original code from Stévant I et.al. Cell Rep. 2019.
rankKeepNA <- function(x) {
    return(
    ifelse(
    is.na(x),
    NA,
    rank(
    x,
    na.last = TRUE,
    ties.method="random"
    )
    )
    )
}

get_pseudotime <- function(pseudotime, wthres=wthres){
    pseudoT <- list()
    for(lineage in 1:length(pseudotime@curves))local({
        curve <- pseudotime@curves[[lineage]]
        lambda <- curve$lambda
        weight <- curve$w
        ps <- curve$lambda
        ps[weight < wthres] <- NA
        ps <- rankKeepNA(ps)
        pseudoT[[lineage]] <<- ps
    })
    df <- t(do.call("rbind",pseudoT))
    colnames(df) <- names(pseudotime@curves)
    return(df)
}

#### Visualization
library(grid)
library(tidyr)
library(ggplot2)
library(rgl)
library("plot3D")

# This function was produced by modifying code (Stévant I et.al. Cell Rep. 2019).
# bty = c("b", "b2", "f", "g", "bl", "bl2", "u", "n")
plot_dm_3D <- function(dm=dm, dc=c(1:3), condition=condition, colours=colours, size=0.5, type = "s", legend = NULL){
    cond <- factor(condition)
    col <- factor(condition)
    levels(col) <- colours
    col <- as.vector(col)
    DCs <- paste("DC",dc, sep="")

    data <- data.frame(
    dm@eigenvectors[,DCs[1]],
    dm@eigenvectors[,DCs[2]],
    dm@eigenvectors[,DCs[3]]
    )
    colnames(data) <- DCs

    plot3d(
    data,
    bg=col,
    col=col,
    size=size,
    type = type,
    box = FALSE
    )

    if (is.null(legend)==FALSE){
        legend3d("topright", legend = unique(condition), pch = 21, pt.bg = unique(col), cex=1.5, inset=c(0.02), bty = "n")
    }
}

# bty = c("b", "b2", "f", "g", "bl", "bl2", "u", "n")
plot_dm_3D_in_2D <- function(dm=dm, dc=c(1:3), condition=condition, colours=colours, outline.color = "grey20", size=1, pch = 21, theta = 40, phi = 40, bty ="b"){
    #cond <- factor(condition)
    cols <- factor(condition)
    levels(cols) <- colours
    cols <- as.vector(cols)
    DCs <- paste("DC",dc, sep="")

    data <- data.frame(
    dm@eigenvectors[,DCs[1]],
    dm@eigenvectors[,DCs[2]],
    dm@eigenvectors[,DCs[3]]
    )
    colnames(data) <- DCs

    if(pch == 21){
        scatter3D(x=as.matrix(data[,DCs[1]]), y=as.matrix(data[,DCs[2]]), z=as.matrix(data[,DCs[3]]), bg = cols, col = outline.color, pch=pch, cex = size, xlab = DCs[1], ylab = DCs[2], zlab = DCs[3], theta =theta, phi = phi, bty = bty)
    } else {
        scatter3D(x=as.matrix(data[,DCs[1]]), y=as.matrix(data[,DCs[2]]), z=as.matrix(data[,DCs[3]]), col = condition, col = cols, pch=pch, cex = size, xlab = DCs[1], ylab = DCs[2], zlab = DCs[3], theta =theta, phi = phi, bty = bty)
    }

}

# myFeaturePlot3D source code
SetQuantile <- function(cutoff, data) {
    if (grepl(pattern = '^q[0-9]{1,2}$', x = as.character(x = cutoff), perl = TRUE)) {
        this.quantile <- as.numeric(x = sub(
        pattern = 'q',
        replacement = '',
        x = as.character(x = cutoff)
        )) / 100
        data <- unlist(x = data)
        data <- data[data > 0]
        cutoff <- quantile(x = data, probs = this.quantile)
    }
    return(as.numeric(x = cutoff))
}

#object: Seurat object
#dataframe: diffusion map results
#DCno: DC
#features.use: gene name

myFeaturePlot3D <- function(dataframe, object, DCno, features.use, pt.size = 0.5, min.exp = -Inf, max.exp = Inf,hl.low.color="#d3d3d3", hl.high.color="red", type = "s") {
    data.plot=data.frame(dataframe[,DCno], FetchData(object = object, vars = features.use))
    data.plot$cell <- rownames(x = data.plot)
    data.plot %>% gather(key = "gene", value = "expression", -DCno, -cell) -> data.plot
    data.plot %>% dplyr::group_by(gene) %>% dplyr::mutate(scaled.expression = scale(expression)) -> data.plot
    min.exp <- SetQuantile(cutoff = min.exp, data = data.plot$scaled.expression)
    max.exp <- SetQuantile(cutoff = max.exp, data = data.plot$scaled.expression)
    data.plot$gene <- factor(x = data.plot$gene, levels = features.use)
    data.plot$scaled.expression <- MinMax(data = data.plot$scaled.expression,min = min.exp,max = max.exp)
    sortlist <- order(data.plot$scaled.expression)
    data.plot <- data.plot[sortlist,]

    p=ggplot(data.plot,aes(x=DCno[1],y=DCno[2]))
    p=p+geom_point(aes(color = scaled.expression), shape=16, size=1)
    p=p+scale_colour_gradient(low = hl.low.color, high = hl.high.color)
    data.plot$color <- ggplot_build(p)$data[1][[1]]$colour
    p3 <- plot3d(data.plot[DCno], col = data.plot$color, size = pt.size, box=FALSE, type=type)
    return(p3)
}

#object: Seurat object
#dataframe: diffusion map results
#DCno: DC
#features.use: gene name
#bty = c("b", "b2", "f", "g", "bl", "bl2", "u", "n")

myFeaturePlot3D_in_Plot2D <- function(dataframe, object, DCno, features.use, pt.size = 1, min.exp = -Inf, max.exp = Inf, hl.low.color="#d3d3d3", hl.high.color="red", outline.color = "grey20", pch=21, theta = 40, phi = 40, bty ="b") {

    data.plot=data.frame(dataframe[,DCno], FetchData(object = object, vars = features.use))
    data.plot$cell <- rownames(x = data.plot)
    data.plot %>% gather(key = "gene", value = "expression", -DCno, -cell) -> data.plot
    data.plot %>% dplyr::group_by(gene) %>% dplyr::mutate(scaled.expression = scale(expression)) -> data.plot
    min.exp <- SetQuantile(cutoff = min.exp, data = data.plot$scaled.expression)
    max.exp <- SetQuantile(cutoff = max.exp, data = data.plot$scaled.expression)
    data.plot$gene <- factor(x = data.plot$gene, levels = features.use)
    data.plot$scaled.expression <- MinMax(data = data.plot$scaled.expression,min = min.exp,max = max.exp)
    sortlist <- order(data.plot$scaled.expression)
    data.plot <- data.plot[sortlist,]

    p=ggplot(data.plot,aes(x=DCno[1],y=DCno[2]))
    p=p+geom_point(aes(color = scaled.expression), shape=16, size=1)
    p=p+scale_colour_gradient(low = hl.low.color, high = hl.high.color)
    data.plot$color <- ggplot_build(p)$data[1][[1]]$colour

    if (pch==21){
        p3 <- scatter3D(x=as.matrix(data.plot[,DCno[1]]), y=as.matrix(data.plot[,DCno[2]]), z=as.matrix(data.plot[,DCno[3]]), bg = data.plot$color, size = pt.size, col = outline.color, pch=pch, theta = theta, phi = phi, fov=90, cex = pt.size, xlab = DCno[1], ylab = DCno[2], zlab = DCno[3], bty = bty, main=features.use)

    } else {
        p3 <- scatter3D(x=as.matrix(data.plot[,DCno[1]]), y=as.matrix(data.plot[,DCno[2]]), z=as.matrix(data.plot[,DCno[3]]), colvar=data.plot$scaled.expression, col = data.plot$color, size = pt.size, pch=pch, theta = theta, phi = phi, fov=90, cex = pt.size, xlab = DCno[1], ylab = DCno[2], zlab = DCno[3], bty = bty,main=features.use)
    }

    return(p3)
}

#### plot_cells_per_lineage in tSNEplot

highlight_cells_per_lineage_tSNEplot <- function(object, highlight.cells, pt.size = 2, pt.shape = 21, outline.color = "grey30", bg.color = "#d3d3d3", hi.color, outline.size = 0.2,title="tSNE map"){

    cell.use.s <- highlight.cells

    data.plot=data.frame(object@reductions$tsne@cell.embeddings,row.names(object@reductions$pca@cell.embeddings),object@active.ident)
    colnames(data.plot) <- c("tSNE_1","tSNE_2","Cell","ident")

    g=ggplot(data.plot,aes(x=tSNE_1,y=tSNE_2))
    g=g+geom_point(size=pt.size, shape=pt.shape, color=outline.color, fill=bg.color, stroke = outline.size)
    g=g+geom_point(data=subset(data.plot, data.plot$Cell %in% cell.use.s), aes(fill =ident), color=outline.color, size=pt.size, shape=pt.shape, stroke = outline.size)
    g=g+scale_fill_manual(values = hi.color,name="")+ggtitle(title)
    g=g+theme_grey()+
    theme(
    axis.text=element_text(size=16),
    axis.title=element_text(size=16),
    legend.text = element_text(size =16),
    legend.title = element_text(size =16 ,face="bold"),
    plot.title = element_text(size=18, face="bold", hjust = 0.5),
    aspect.ratio=1
    )
    return(g)
}

#### plot_cells_per_lineage in 3D diffusionmap

## ex
# curves <- slingCurves(male_lineage)
# add.curve <- curves$curve1

#bty = c("b", "b2", "f", "g", "bl", "bl2", "u", "n")

highlight_cells_per_lineage_dmplot3D <- function(object, dm=dm, dc=c(1:3), highlight.cells, condition=condition, colours=colours, lineage.curve=NULL, size=1, pch = 21, outline.color = "grey20", bg.color = "#d3d3d3", title="Diffusion map",phi = 40, theta = 40, add.curve=NULL, bty ="b"){

    cell.use.s <- highlight.cells

    cols <- factor(condition)
    levels(cols) <- colours
    cols <- as.vector(cols)
    DCs <- paste("DC",dc, sep="")

    data <- data.frame(
    dm@eigenvectors[,DCs[1]],
    dm@eigenvectors[,DCs[2]],
    dm@eigenvectors[,DCs[3]],
    Cell=row.names(object@reductions$pca@cell.embeddings),
    Ident=condition,
    Color=cols
    )
    colnames(data) <- c(DCs,"Cell","ident","Color")

    data2=subset(data, data$Cell %in%　cell.use.s)

    scatter3D(x=as.matrix(data[,DCs[1]]), y=as.matrix(data[,DCs[2]]), z=as.matrix(data[,DCs[3]]), bg = bg.color, col = outline.color, pch=pch, cex = size, xlab = DCs[1], ylab = DCs[2], zlab = DCs[3], theta =theta, phi = phi, main =title, bty = bty)
    scatter3D(x=as.matrix(data2[,DCs[1]]), y=as.matrix(data2[,DCs[2]]), z=as.matrix(data2[,DCs[3]]), bg = as.matrix(data2[,"Color"]), col = outline.color, pch=pch, cex = size, xlab = DCs[1], ylab = DCs[2], zlab = DCs[3], theta =theta, phi = phi, add=TRUE, bty = bty)

    if(is.null(add.curve)==FALSE){
        c <- add.curve
        scatter3D(x = c$s[c$ord,DCs[1]], y =c$s[c$ord,DCs[2]], z = c$s[c$ord,DCs[3]], col = "black", type = "l", ticktype = "detailed", lwd = 4, add = TRUE, xlab = DCs[1], ylab = DCs[2], zlab = DCs[3], theta =theta, phi = phi, bty = bty)
    }

}


# Goal: Reading and writing ascii files, reading and writing binary files.
#       And, to measure how much faster it is working with binary files.

# First manufacture a tall data frame:
                # FYI -- runif(10) yields 10 U(0,1) random numbers.
B = data.frame(x1=runif(100000), x2=runif(100000), x3=runif(100000))
summary(B)

# Write out ascii file:
write.table(B, file = "/tmp/foo.csv", sep = ",", col.names = NA)
# Read in this resulting ascii file:
C=read.table("/tmp/foo.csv", header = TRUE, sep = ",", row.names=1)
# Write a binary file out of dataset C:
save(C, file="/tmp/foo.binary")
# Delete the dataset C:
rm(C)
# Restore from foo.binary:
load("/tmp/foo.binary")
summary(C)                              # should yield the same results
                                        # as summary(B) above.

# Now we time all these operations --
cat("Time creation of dataset:\n")
system.time({
  B = data.frame(x1=runif(100000), x2=runif(100000), x3=runif(100000))
})

cat("Time writing an ascii file out of dataset B:\n")
system.time(
            write.table(B, file = "/tmp/foo.csv", sep = ",", col.names = NA)
            )

cat("Time reading an ascii file into dataset C:\n")
system.time(
            {C=read.table("/tmp/foo.csv", header = TRUE, sep=",", row.names=1)
           })

cat("Time writing a binary file out of dataset C:\n")
system.time(save(C, file="/tmp/foo.binary"))

cat("Time reading a binary file + variablenames from /tmp/foo.binary:\n")
system.time(load("/tmp/foo.binary"))    # and then read it in from binary file

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/r4.r


#' Select predictor that create best fit model using forward selection methods
#'
#' @param data a data frame
#' @param formula specify dependent and independent variables for glm formula
#'
#' @return a  list of candidate variables, list of added variables, and stepwise
#' summary table
#' @export
#'
#' @examples
#' stepwise_selection(data = ToothGrowth, supp ~ .)
stepwise_selection <- function(data, formula) {
  model <- stats::glm(formula, data, family = stats::binomial(logit))
  blorr::blr_step_aic_both(model)
}


# In the integrated analysis, all of the data components share the same mean Linf parameter ("mu.Linf").
# The tagging and otolith components include a random Linf parameter, so also share the same "sig.Linf";
# whereas the length-frequency component does not include a random Linf (thus no "sig.Linf") since
# the data are for young fish that are not near their asymptotic length.

# There is no information about the a0 parameter from the tagging data, so this parameter is estimated
# from the otolith and length-frequency data sets

# The variance parameters are assumed to be unique for each data set

# The length-frequency (LF) component assumes that a model decomposition has already been applied to the
# raw data, such that the dataset input to the growth analysis is the lengths and ages corresponding to
# the modes in the LF data.

# - param.f contains the parameters of the growth function, f (note L=Linf*f, so param.f does not include Linf)
#   (e.g. param.f={k} for the standard VB model; param.f={k,u,w} for VB with seasonal growth)
# - npf = number of parameters for the growth function, f; i.e., length of param.f
#   (e.g. npf=1 for standard VB; npf=3 for VB with seasonal growth)
# - param.A contains the parameters for the distribution of A (e.g. log normal in our example)
# - npA = number of parameters for distribution of A, i.e., length of param.A (e.g. npA=2 for log normal)
# - param contains all of the parameters being estimated, including the variance parameters; note that
#   for the tagging component, we allow measurement error in length to be different for scientists vs fishermen
#   since many of our recaptures were measured by fishermen, hence the 2 variance parameters sig.s and sig.f
#   (e.g., param = {mu.Linf, sig.Linf, param.f, param.A, sig.s, sig.f, a0, sig.oto, sig.lf}

# 1) Otolith negative log-likelihood component:
# - assumes data is a matrix with columns: age, length

logl.oto.f <- function(param, npf, npA, otodat)
{
  #print(param)
  # Get data:
	age <- otodat[, 1]
	len <- otodat[, 2]
  n <- nrow(otodat)

	# Get param:
	mu.L <- param[1]
	sig.L <- param[2]
	param.f <- param[3:(npf+2)]
	a0 <- param[2+npf+npA+3]
	sig.oto <- param[2+npf+npA+4]

	grwth <- growth.ssnl.f(age - a0, param.f, age)
	exp.len <- mu.L * grwth
	var.len <- (grwth * sig.L)^2 + sig.oto^2
	neglogl <- 1/2 * sum(log(2 * pi * var.len) + ((len - exp.len)^2)/var.len)

	#print(neglogl)
	return(neglogl)
}

#2) Length-frequency (LF) negative log-likelihood component:
# - assumes data is in a matrix with columns: age, mean.mode, se.mode

logl.lf.f <- function(param, npf, npA, lfdat)
{
	# Get data:
	age <- lfdat[, 1]
	mu.mode <- lfdat[, 2]
	se.mode <- lfdat[, 3]
	n <- nrow(lfdat)

	# Get parameters:
	mu.L <- param[1]
	param.f <- param[3:(npf+2)]
	a0 <- param[2+npf+npA+3]
	#a0 = 0 # Note: Uncomment this to remove the effect of fitting a0.
	sig.lf <- param[2+npf+npA+5]

	grwth <- growth.ssnl.f(age - a0, param.f, age)
	exp.mode <- mu.L * grwth
	var.mode <- sig.lf^2 + se.mode^2
	neglogl <- 1/2 * sum(log(2 * pi * var.mode) + ((mu.mode - exp.mode)^2)/var.mode)
	#print(param)
	#print(neglogl)
	return(neglogl)
}

#3) Tagging negative log-likelihood component:
# - code and description found in file 'tag lkhd.r'
#source("/Users/stephenscherrer/Google Drive/Weng Lab/Data/Bottomfish/Okamoto's 1990s Mark Recapture Data/src/Laslett Functions/tag_lkhd.r")

# JOINT LIKELIHOOD:
joint.logl.f <- function(param,npf,npA,tagdat,otodat,lfdat,wt.oto=1,wt.tag=1,wt.lf=1)
{
  neglogl.tag<- 0
  neglogl.oto<- 0
  neglogl.lf<- 0
  if(wt.tag>0)  neglogl.tag <- logl.ssnl.f(param,npf,npA,tagdat)
  if(wt.oto>0)  neglogl.oto <- logl.oto.f(param,npf,npA,otodat)
  if(wt.lf>0) neglogl.lf <- logl.lf.f(param,npf,npA,lfdat)
  neglogl <- wt.tag*neglogl.tag + wt.oto*neglogl.oto + wt.lf*neglogl.lf
  #print(param)
  #print(c(neglogl.tag, neglogl.oto, neglogl.lf, neglogl))
  return(neglogl)
}

# where...

# logl.ssnl.f is for tagging data and is found in "tag lkhd.r" (along with all
# necessary associated functions)


cat('get_contrast_matrix_rows_as_list() now available as a function\n')
get_contrast_matrix_rows_as_list = function(
	data
	, formula
	, contrast_kind = NULL
){
	mm = get_contrast_matrix(data, formula, contrast_kind )
	mm_list = lapply(
		X = seq_len(nrow(mm))
		, FUN = function(i){
			out = as_tibble(array(
				mm[i,]
				, dim = c(1,ncol(mm))
				, dimnames = list(
					NULL
					, dimnames(mm)[[2]]
				)
			))
			names(out) = dimnames(mm)[[2]]
			return(out)
		}
	)
	return(mm_list)
}


library(data.table)
library(rstan)
options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)

dat = readRDS("~/work/teaching/BayesCourseIGB/data/trees.rds")
spp = data.table(species = c("18032-ABI-BAL", "19489-BET-PAP", "28731-ACE-SAC",
			"195773-POP-TRE", "183397-TSU-CAN"),
			species_name = c("Abies balsamifera", "Betula papyrifera", "Acer saccharum",
			"Populus tremuloides", "Tsuga canadensis"))
years = c(1975, 1980, 1985, 1988, 1989, 1990, 1993:2012)
dat = dat[spp, , on = "species"][year %in% years,
			.(n, died, year, species_name, annual_mean_temp, tot_annual_pp, prior_mu)]
dat = dat[n > 0]
fwrite(dat, "docs/exercises/data/treedata.csv", row.names=FALSE)


# Define UI for application that draws the plot

shiny::shinyUI(shiny::fluidPage(

  # Application title
  shiny::titlePanel("Response to selection with several locations and years"),

  # Input values
  shiny::sidebarLayout(
    shiny::sidebarPanel(
      shiny::numericInput("N",
                         "Plot capacity:",
                         min = 100,
                         max = 10000,
                         step = 100,
                         value = 1000),
      shiny::numericInput("k",
                          "Number of locations:",
                          min = 1,
                          max = 100,
                          step = 1,
                          value = 3),
      shiny::numericInput("q",
                          "Number of years:",
                          min = 1,
                          max = 100,
                          step = 1,
                          value = 3),
      shiny::numericInput("sg1",
                         "Number of selected genotypes:",
                         min = 0,
                         max = 10000,
                         step = 10,
                         value = 10),
      shiny::numericInput("sigmaG2",
                         "Genotypic variance:",
                         min = 0,
                         max = 1000,
                         step = 0.1,
                         value = 1),
      shiny::numericInput("sigmaGL2",
                          "Genotypic x location variance:",
                          min = 0,
                          max = 1000,
                          step = 0.1,
                          value = 1),
      shiny::numericInput("sigmaGY2",
                          "Genotypic x year variance:",
                          min = 0,
                          max = 1000,
                          step = 0.1,
                          value = 1),
      shiny::numericInput("sigmaGLY2",
                          "Genotypic x location x year variance:",
                          min = 0,
                          max = 1000,
                          step = 0.1,
                          value = 1),
      shiny::numericInput("sigmaE2",
                          "Error variance:",
                          min = 0,
                          max = 1000,
                          step = 0.1,
                          value = 1)
    ),

    # Show the plot

    shiny::mainPanel(
      shiny::plotOutput("rtsplot3")
    )
  )
))


input <- file('stdin', 'r')

n <- as.double(readLines(input, n=1))

result = sprintf("A=%.4f", n * n * 3.14159)
write(result, "")


library(dplyr)
library(ggplot2)

setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
cln <- read.table("../data/workshops.csv", sep = ";", h = T)

#### Piechart ------------------------------------------------------------------
x  <- c("1 - Excellent", "2 - Good", "3 - Fair", "4 - Poor")
y  <- table(cln$Instructor.s.pacing.within.allotted.time)
df <- data.frame(group = x, value = as.numeric(y))

df <- df %>%
arrange(desc(group)) %>%
mutate(prop = value / sum(df$value) *100) %>%
mutate(ypos = cumsum(prop)- 0.5*prop )

g1 <- ggplot(df, aes(x="", y=prop, fill=group)) +
  geom_bar(stat="identity", width=1.0, color="white") +
  coord_polar("y", start=0) +
  theme_void() +
  theme(legend.position="none") +
  ggtitle("Instructor's pacing within allotted time (n = 204)") +
  geom_text(aes(y = ypos, label = group), color = "black", size = 2.5) +
  scale_fill_brewer(palette="Set1")
ggsave("../plots/01_piechart.png", g1, width = 4, height = 4)

#### Scatterplot ---------------------------------------------------------------
score <- tapply(cln$Overall, cln$ID, mean)
size  <- tapply(cln$Overall, cln$ID, length)
df    <- data.frame(score = score, size = size)

g1 <- ggplot(df, aes(size, score)) + geom_point() +
  geom_smooth(formula = y ~ x, method = "lm", se = FALSE) +
  xlab("number of participants") +
  ylab("average overall score") +
  annotate("text", x = 20, y =  1.7, colour = "red",
           label = paste0("cor. coeff. = ", round(cor(df$size, df$score), 2)))
ggsave("../plots/01_scatterplot.png", g1, width = 4, height = 4)

#### Barchart 1 ----------------------------------------------------------------
df <- data.frame(ID = 1:16, size = size)
g1 <- ggplot(df, aes(ID, size)) + geom_bar(stat = "identity") +
  xlab("workshop ID") + ylab("number of participants") +
  geom_hline(yintercept = mean(df$size), colour = "red", lty = "dashed") +
  annotate("text", x = 3, y =  1 + mean(df$size), colour = "red",
           label = paste0("average = ", mean(df$size)))
ggsave("../plots/01_barchart-participants.png", g1, width = 6, height = 4)

#### Barchart 2 ----------------------------------------------------------------
x <- cln$Instructor.s.pacing.within.allotted.time
score_all <- table(x[cln$ID != 6]) / length(x[cln$ID != 6])
score_one <- table(x[cln$ID == 6]) / length(x[cln$ID == 6])

x <- c("1 - Excellent", "2 - Good", "3 - Fair", "4 - Poor")
df <- data.frame(count = c(score_one, score_all),
                 grade = rep(x, 2),
                 group = rep(c("instructor", "overall"), each = 4))

g1 <- ggplot(df, aes(grade, count, fill = group)) +
  geom_bar(stat = "identity", position = "dodge") +
  xlab("grade") + ylab("%") +
  ggtitle("Instructor's pacing within allotted time (n = 192, 11)")
ggsave("../plots/01_barchart-instructor.png", g1, width = 6, height = 4)


sites.coxph <- function(methylation, design, dependent.variable, ...) {
    formula <- as.formula(paste(dependent.variable, "~ ."))
    design <- as.data.frame(design)
    ret <- rep(NA, 5)
    stats <- do.call(rbind, mclapply(1:nrow(methylation), function(i) {
        design[,"methylation"] <- methylation[i,]
        try({
            fit <- coxph(formula, design, ...)
            ret <- coef(summary(fit))["methylation",]
            names(ret) <- c("estimate","exp.estimate","se","z","p.value")
            ret[["n"]] <- fit$n
            ret
        }, silent=T)
        ret
    }))
    stats <- as.data.frame(stats)
    stats$n <- floor(stats$n)
    stats
}


library(tidyverse)
source('fwhm.R')
source('LeT_sd_versionsV2.r')

theta = 0.1; W0 = 0.12
alpha = 1; beta = 0.2
pfood = 0.75
mu = 1; sd = 0.2
trials = 60 * 8
tx = 60
tpeak = tx * 3
prop_tr = 0.1

n = tpeak * 3
params = c(n, mu, sd, alpha, beta, W0, theta, pfood)

wn_vector = numeric(n)
sesiones = 50
sL = vector('list', sesiones)

for (j in 1:sesiones) {

  if (j > 1) {
    wn_vector = sL[[j - 1]][[5]]
  }

  sL[[j]] = LeT_peak_deg(tx, tpeak, prop_tr,
                         trials, params,wn_vector, same_sd = F)
}

df = data.frame()
fwhm1 = c()
fwhm2 = c()
peak1 = c()
peak2 = c()
i1 = c()
i2 = c()

for (i in 20:sesiones) {
  R1 = sL[[i]][[3]][ ,1:180]
  R2 = sL[[i]][[4]][ ,1:180]

  Wn1 = sL[[i]][['Wn1']][1:180]
  iriD = sL[[i]][['iri1']]
  iriIm = sL[[i]][['iri2']]

  i1 = c(i1, iriD)
  i2 = c(i2, iriIm)

  sumsR1 = colSums(R1)
  sumsR2 = colSums(R2)

  d1 = density(sumsR1)
  d2 = density(sumsR2)

  ft1 = fwhm(d1$x, d1$y)
  ft2 = fwhm(d2$x, d2$y)

  fwhm1 = c(fwhm1, ft1$fwhm)
  peak1 = c(peak1, ft1$peak)

  fwhm2 = c(fwhm2, ft2$fwhm)
  peak2 = c(peak2, ft2$peak)

  dfTmp = data.frame(bin = 1:180,
                     R1 = sumsR1,
                     R2 = sumsR2,
                     Wn1 = Wn1,
                     sesion = i)
  df = rbind(df, dfTmp)
}

df_summary = df %>%
  group_by(bin) %>%
  summarise(r1 = mean(R1) / 180,
            r2 = mean(R2) / 180,
            wn1 = mean(Wn1))

# save(sL, dfFWHM, df_summary, file = 'LeT_PeakDiffSD.RData')

## Same rate lambda for both components

wn_vector = numeric(n)
sesiones = 50
sL = vector('list', sesiones)

for (j in 1:sesiones) {

  if (j > 1) {
    wn_vector = sL[[j - 1]][[5]]
  }

  sL[[j]] = LeT_peak_deg(tx, tpeak, prop_tr,
                         trials, params,wn_vector, same_sd = T)
}

df = data.frame()
fwhm1 = c()
fwhm2 = c()
peak1 = c()
peak2 = c()
i1 = c()
i2 = c()

for (i in 1:sesiones) {
  R1 = sL[[i]][[3]][ ,1:180]
  R2 = sL[[i]][[4]][ ,1:180]

  Wn1 = sL[[i]][['Wn1']][1:180]
  iriD = sL[[i]][['iri1']]
  iriIm = sL[[i]][['iri2']]

  i1 = c(i1, iriD)
  i2 = c(i2, iriIm)

  sumsR1 = colSums(R1)
  sumsR2 = colSums(R2)

  d1 = density(sumsR1)
  d2 = density(sumsR2)

  ft1 = fwhm(d1$x, d1$y)
  ft2 = fwhm(d2$x, d2$y)

  fwhm1 = c(fwhm1, ft1$fwhm)
  peak1 = c(peak1, ft1$peak)

  fwhm2 = c(fwhm2, ft2$fwhm)
  peak2 = c(peak2, ft2$peak)

  dfTmp = data.frame(bin = 1:180,
                     R1 = sumsR1,
                     R2 = sumsR2,
                     Wn1 = Wn1,
                     sesion = i)
  df = rbind(df, dfTmp)
}

df_summary = df %>%
  group_by(bin) %>%
  summarise(r1 = mean(R1) / 180,
            r2 = mean(R2) / 180,
            wn1 = mean(Wn1))

# save(sL, dfFWHM, df_summary, file = 'LeT_PeakSameSD.RData')


#----- NETWORK VISUALISATION -----#
# weighted adjacency matrix
graph = data.frame(Ambient = c(30,  3, 12,  3,  2),
                   Funk =    c( 2, 14, 11,  5, 17),
                   Garage =  c(15,  8, 22,  3,  2),
                   Pop =     c( 2,  9,  2, 34,  3),
                   Kawaii =  c( 1, 21,  0,  5, 22))

#----- SOME FUNCTIONS -----#

# Remove unnecessary data received from the Spotify API, and
# select which columns are usefull to us.
remove_junk <- function(data) {
    select(data,Genre=playlist_name,
           PlaylistLength=playlist_num_tracks,
           Artist=artist_name,
           Album=album_name,
           Track=track_name,
           Date=track_added_at,
           Popularity=track_popularity,
           Danceability=danceability,
           Energy=energy,
           Key=key,
           Loudness=loudness,
           Mode=mode,
           Speechiness=speechiness,
           Acousticness=acousticness,
           Instrumentalness=instrumentalness,
           Liveness=liveness,
           Valence=valence,
           Tempo=tempo,
           Duration=duration_ms,
           TimeSignature=time_signature,
           KeyMode=key_mode)
}

circshift <- function(v, n) {if (n == 0) v else c(tail(v, n), head(v, -n))}

    # C     C#    D     Eb    E     F     F#    G     Ab    A     Bb    B
major_chord <-
    c(1,    0,    0,    0,    1,    0,    0,    1,    0,    0,    0,    0)
minor_chord <-
    c(1,    0,    0,    1,    0,    0,    0,    1,    0,    0,    0,    0)
seventh_chord <-
    c(1,    0,    0,    0,    1,    0,    0,    1,    0,    0,    1,    0)

major_key <-
    c(6.35, 2.23, 3.48, 2.33, 4.38, 4.09, 2.52, 5.19, 2.39, 3.66, 2.29, 2.88)
minor_key <-
    c(6.33, 2.68, 3.52, 5.38, 2.60, 3.53, 2.54, 4.75, 3.98, 2.69, 3.34, 3.17)

chord_templates <-
    tribble(
        ~name  , ~template,
        'Gb:7'  , circshift(seventh_chord,  6),
        'Gb:maj', circshift(major_chord,    6),
        'Bb:min', circshift(minor_chord,   10),
        'Db:maj', circshift(major_chord,    1),
        'F:min' , circshift(minor_chord,    5),
        'Ab:7'  , circshift(seventh_chord,  8),
        'Ab:maj', circshift(major_chord,    8),
        'C:min' , circshift(minor_chord,    0),
        'Eb:7'  , circshift(seventh_chord,  3),
        'Eb:maj', circshift(major_chord,    3),
        'G:min' , circshift(minor_chord,    7),
        'Bb:7'  , circshift(seventh_chord, 10),
        'Bb:maj', circshift(major_chord,   10),
        'D:min' , circshift(minor_chord,    2),
        'F:7'   , circshift(seventh_chord,  5),
        'F:maj' , circshift(major_chord,    5),
        'A:min' , circshift(minor_chord,    9),
        'C:7'   , circshift(seventh_chord,  0),
        'C:maj' , circshift(major_chord,    0),
        'E:min' , circshift(minor_chord,    4),
        'G:7'   , circshift(seventh_chord,  7),
        'G:maj' , circshift(major_chord,    7),
        'B:min' , circshift(minor_chord,   11),
        'D:7'   , circshift(seventh_chord,  2),
        'D:maj' , circshift(major_chord,    2),
        'F#:min', circshift(minor_chord,    6),
        'A:7'   , circshift(seventh_chord,  9),
        'A:maj' , circshift(major_chord,    9),
        'C#:min', circshift(minor_chord,    1),
        'E:7'   , circshift(seventh_chord,  4),
        'E:maj' , circshift(major_chord,    4),
        'G#:min', circshift(minor_chord,    8),
        'B:7'   , circshift(seventh_chord, 11),
        'B:maj' , circshift(major_chord,   11),
        'D#:min', circshift(minor_chord,    3),
)

key_templates <-
    tribble(
        ~name    , ~template,
        'Gb:maj', circshift(major_key,  6),
        'Bb:min', circshift(minor_key, 10),
        'Db:maj', circshift(major_key,  1),
        'F:min' , circshift(minor_key,  5),
        'Ab:maj', circshift(major_key,  8),
        'C:min' , circshift(minor_key,  0),
        'Eb:maj', circshift(major_key,  3),
        'G:min' , circshift(minor_key,  7),
        'Bb:maj', circshift(major_key, 10),
        'D:min' , circshift(minor_key,  2),
        'F:maj' , circshift(major_key,  5),
        'A:min' , circshift(minor_key,  9),
        'C:maj' , circshift(major_key,  0),
        'E:min' , circshift(minor_key,  4),
        'G:maj' , circshift(major_key,  7),
        'B:min' , circshift(minor_key, 11),
        'D:maj' , circshift(major_key,  2),
        'F#:min', circshift(minor_key,  6),
        'A:maj' , circshift(major_key,  9),
        'C#:min', circshift(minor_key,  1),
        'E:maj' , circshift(major_key,  4),
        'G#:min', circshift(minor_key,  8),
        'B:maj' , circshift(major_key, 11),
        'D#:min', circshift(minor_key,  3))

get_analysis <- function(id) {
    # return(get_tidy_audio_analysis(id) %>%
    #        select(segments) %>%
    #        unnest(segments) %>%
    #        select(start, duration, pitches))
    return(get_tidy_audio_analysis(id) %>%
    compmus_align(bars, segments) %>%
    select(bars) %>% unnest(bars) %>%
    mutate(
        pitches =
            map(segments,
                compmus_summarise, pitches,
                method = 'rms', norm = 'manhattan')) %>%
    mutate(
        timbre =
            map(segments,
                compmus_summarise, timbre,
                method = 'mean')))
}

plot_chroma <- function(data) {
    return(data %>%
        mutate(pitches = map(pitches, compmus_normalise, 'euclidean')) %>%
        compmus_gather_chroma %>%
        ggplot(
            aes(
                x = start + duration / 2,
                width = duration,
                y = pitch_class,
                fill = value)) +
        geom_tile() +
        labs(x = 'Time (s)', y = NULL, fill = 'Magnitude') +
        theme_minimal() +
        theme(aspect.ratio=2/4))
}

plot_cesptro <- function(data) {
    return(data %>%
        compmus_gather_timbre %>%
        ggplot(
            aes(
                x = start + duration / 2,
                width = duration,
                y = basis,
                fill = value)) +
        geom_tile() +
        labs(x = 'Time (s)', y = NULL, fill = 'Magnitude') +
        scale_fill_viridis_c(option = 'E') +
        theme_classic() +
        theme(aspect.ratio=2/4))
}

plot_ssm <- function(data) {
    return(data %>%
        compmus_self_similarity(timbre, 'cosine') %>%
        ggplot(
            aes(
                x = xstart + xduration / 2,
                width = xduration,
                y = ystart + yduration / 2,
                height = yduration,
                fill = d)) +
        geom_tile() +
        coord_fixed() +
        scale_fill_viridis_c(option = 'E', guide = 'none') +
        theme_classic() +
        labs(x = '', y = ''))
}

plot_chord <- function(data) {
    return(data %>%
        compmus_match_pitch_template(chord_templates, 'euclidean', 'manhattan') %>%
        ggplot(
            aes(x = start + duration / 2, width = duration, y = name, fill = d)) +
        geom_tile() +
        scale_fill_viridis_c(option = 'E', guide = 'none') +
        theme_minimal() +
        labs(x = 'Time (s)', y = '') +
        theme(aspect.ratio=4/4))
}

# -------- Load Data --------- #

# Playlist data
if (!file.exists("data/ff.rds")) {
    future_funk <- remove_junk(get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","4a0xb2zui3hIPll7CMgeSu"))
    saveRDS(future_funk, "data/ff.rds")
} else {
    future_funk <- readRDS("data/ff.rds")
}

if (!file.exists("data/kfb.rds")) {
    kawaii_future_bass <- remove_junk( get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","75OfhBfc4tnQ8MFdiPiMcx"))
    saveRDS(kawaii_future_bass, "data/kfb.rds")
} else {
    kawaii_future_bass <- readRDS("data/kfb.rds")
}

if (!file.exists("data/fp.rds")) {
    futurepop <- remove_junk(get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","1TBQdi8VdYsvruWv1W5HjB"))
    saveRDS(futurepop, "data/fp.rds")
} else {
    futurepop <- readRDS("data/fp.rds")
}

if (!file.exists("data/fa.rds")) {
    future_ambient <- remove_junk(get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","2dZ7eWcGRtuyseKY5QNZoP"))
    saveRDS(future_ambient, "data/fa.rds")
} else {
    future_ambient <- readRDS("data/fa.rds")
}

if (!file.exists("data/fg.rds")) {
    future_garage <- remove_junk(get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","2IgZ50kclGP2tNVx7mu9vL"))
    saveRDS(future_garage, "data/fg.rds")
} else {
    future_garage <- readRDS("data/fg.rds")
}

# Playlist audio feature
if (!file.exists("data/ff_full.rds")) {
    future_funk_full <- get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","4a0xb2zui3hIPll7CMgeSu") %>%
        add_audio_analysis
    saveRDS(future_funk_full, "data/ff_full.rds")
} else {
    future_funk_full <- readRDS("data/ff_full.rds")
}

if (!file.exists("data/kfb_full.rds")) {
    kawaii_future_bass_full <-  get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","75OfhBfc4tnQ8MFdiPiMcx") %>%
        add_audio_analysis
    saveRDS(kawaii_future_bass_full, "data/kfb_full.rds")
} else {
    kawaii_future_bass_full <- readRDS("data/kfb_full.rds")
}

if (!file.exists("data/fp_full.rds")) {
    futurepop_full <- get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","1TBQdi8VdYsvruWv1W5HjB") %>%
        add_audio_analysis
    saveRDS(futurepop_full, "data/fp_full.rds")
} else {
    futurepop_full <- readRDS("data/fp_full.rds")
}

if (!file.exists("data/fa_full.rds")) {
    future_ambient_full <- get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","2dZ7eWcGRtuyseKY5QNZoP") %>%
        add_audio_analysis
    saveRDS(future_ambient_full, "data/fa_full.rds")
} else {
    future_ambient_full <- readRDS("data/fa_full.rds")
}

if (!file.exists("data/fg_full.rds")) {
    future_garage_full <- get_playlist_audio_features("bkd0b33gypt1ixtyg44x4y2ui","2IgZ50kclGP2tNVx7mu9vL") %>%
        add_audio_analysis
    saveRDS(future_garage_full, "data/fg_full.rds")
} else {
    future_garage_full <- readRDS("data/fg_full.rds")
}

if (!file.exists("data/future_full.rds")) {
    # Gather all the data
    future_full <-
        future_funk_full %>% mutate(playlist = "Future Funk") %>%
        bind_rows(
            kawaii_future_bass_full %>% mutate(playlist = "Kawaii Future Bass"),
            futurepop_full %>% mutate(playlist = "Futurepop"),
            future_ambient_full %>% mutate(playlist = "Future Ambient"),
            future_garage_full %>% mutate(playlist = "Future Garage")) %>%
        mutate(playlist = factor(playlist)) %>%
        mutate(
            segments =
                map2(segments, key, compmus_c_transpose)) %>%
        mutate(
            pitches =
                map(segments,
                    compmus_summarise, pitches,
                    method = 'mean', norm = 'manhattan'),
            timbre =
                map(
                    segments,
                    compmus_summarise, timbre,
                    method = 'mean')) %>%
        mutate(pitches = map(pitches, compmus_normalise, 'clr')) %>%
        mutate_at(vars(pitches, timbre), map, bind_rows) %>%
        unnest(pitches, timbre)

    saveRDS(future_full, "data/future_full.rds")
} else {
    future_full <- readRDS("data/future_full.rds")
}


# Support vector machine binary relevance
#library(e1071) # too slow
library(liquidSVM)
library(hydroGOF)
library(future)
plan("multiprocess")

source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/crossvalidation.r")
source("pixel-based/utils/subpixel-confusion-matrix.r")
source("utils/accuracy-statistics.r")

Data.df = LoadTrainingAndCovariates()
Data.df = st_set_geometry(Data.df, NULL)
# Manually rescale
Data.df[,GetAllPixelCovars()] = as.matrix(apply(Data.df[,GetAllPixelCovars()], 2, scale))
Data.df[is.na(Data.df)] = -9999
Data.df = TidyData(Data.df, drop.cols=NULL)

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val = st_set_geometry(Data.val, NULL)
Data.val[,GetAllPixelCovars()] = as.matrix(apply(Data.val[,GetAllPixelCovars()], 2, scale))
Data.val[is.na(Data.val)] = -9999
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050

Classes = GetCommonClassNames()
Truth = Data.val[,Classes]

# Thes are too slow, do not finish training in a day
# SVMDefaultTask = future({
#     BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, svm, Data.val, filename="../data/pixel-based/predictions/svm-defaults.csv")
# })
# resolved(SVMDefaultTask)
# Predictions = value(SVMDefaultTask)
# AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 19.1, MAE 8.4, similar to RF two-model
# SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 71%±2, kappa 0.62±0.03
# NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.59
# PlotHex(Predictions[,Classes], Truth[,Classes], "Cubist, defaults, NA set to -9999")
# PlotBox(Predictions[,Classes], Truth[,Classes], main="Cubist, defaults, NA set to -9999") # Still the same issue with underprediction
#
# TunedSVM = function(formula, data, ...)
# {
#     SVMTuning = tune(svm, formula, data = data, ranges = list(epsilon = seq(0,1,0.01), cost = 2^(2:9)))
#     return(SVMTuning$best.model)
# }
#
# SVMTunedTask = future({
#     BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, TunedSVM, Data.val, filename="../data/pixel-based/predictions/svm-defaults.csv")
# })
# resolved(SVMTunedTask)
# Predictions = value(SVMTunedTask)
# AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 19.1, MAE 8.4, similar to RF two-model
# SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 71%±2, kappa 0.62±0.03
# NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.59
# PlotHex(Predictions[,Classes], Truth[,Classes], "Cubist, defaults, NA set to -9999")
# PlotBox(Predictions[,Classes], Truth[,Classes], main="Cubist, defaults, NA set to -9999") # Still the same issue with underprediction

lsSVMW = function(formula, data, scale_classifier=FALSE, ...) lsSVM(x=formula,y=data, scale=scale_classifier, ...)
qtSVMW = function(formula, data, scale_classifier=FALSE, ...) qtSVM(x=formula,y=data, scale=scale_classifier, ...)

# Unfortunately due to internal threading it doesn't work well with futures
Predictions = BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, lsSVMW,Data.val, filename="../data/pixel-based/predictions/svm-defaults.csv")
# We get negative values! Set those to zero and rescale.
Predictions[Predictions < 0] = 0
Predictions = ScalePredictions(Predictions, FALSE)
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 20.4, MAE 11.2, pretty poor but in the ballpark
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 61%±4, kappa 0.49±0.05
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.53
PlotHex(Predictions[,Classes], Truth[,Classes], "SVM, defaults, NA set to -9999")
PlotBox(Predictions[,Classes], Truth[,Classes], TRUE, main="SVM, defaults, NA set to -9999") # Still the same issue with underprediction

# It seems that >100 also occurs, try manual scaling
Predictions = BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, lsSVMW, Data.val, scale=FALSE, filename="../data/pixel-based/predictions/svm-scale.csv")
Predictions[Predictions < 0] = 0
Predictions[Predictions > 100] = 100
Predictions = ScalePredictions(Predictions, FALSE)
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 18.6, MAE 9.9, close to RF single model but not quite there
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 65%±4, kappa 0.55±0.05
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.61
PlotHex(Predictions[,Classes], Truth[,Classes], "SVM, scaled")
PlotBox(Predictions[,Classes], Truth[,Classes], TRUE, main="SVM, scaled") # Still the same issue with underprediction

# Quantile SVM - medians; suggestion to set max_gamma to 25
Predictions = BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, qtSVMW, weights=0.5, threads=11, scale=FALSE, Data.val, filename="../data/pixel-based/predictions/svm-median.csv")
# We get negative values! Set those to zero and rescale.
Predictions[Predictions < 0] = 0
Predictions[Predictions > 100] = 100
Predictions = ScalePredictions(Predictions, FALSE)
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 20.7, MAE 8.9, close to median forest but not quite there
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 69%±2, kappa 0.58±0.03
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.52
PlotHex(Predictions[,Classes], Truth[,Classes], "SVM, median")
PlotBox(Predictions[,Classes], Truth[,Classes], TRUE, main="SVM, median") # Still the same issue with underprediction

# Try scale and max_gamma
Predictions = BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, qtSVMW, weights=0.5, threads=11, scale=FALSE, max_gamma=25, Data.val, filename="../data/pixel-based/predictions/svm-median-maxgamma25.csv")
# We get negative values! Set those to zero and rescale.
Predictions[Predictions < 0] = 0
Predictions[Predictions > 100] = 100
Predictions = ScalePredictions(Predictions, FALSE)
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 20.7, MAE 8.9, no change
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 69%±2, kappa 0.58±0.03
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.52
PlotHex(Predictions[,Classes], Truth[,Classes], "SVM, median")
PlotBox(Predictions[,Classes], Truth[,Classes], TRUE, main="SVM, median") # Still the same issue with underprediction


#' @title modes
#' @description find the largest mode
#' @family abysmally documented
#' @author unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
modes = function( Z, eps=0, ... ) {
  debug = FALSE
  if (debug) {
    # construct something that looks like a profile
    Z = - 50 * cos( seq(-pi/2, pi/2, by=.02) )
    mid = trunc( length(Z) / 2 )
    Z = c( Z[1:mid], Z[mid] + ( runif( length(Z) )-0.5)*5, Z[mid:length(Z)] )
    Z = max(Z) -Z
    plot(Z)
    modes( Z)
    kernal.bw.method="sj"
  }

  # kernel density based approach
  require(numDeriv)

  # simple determination from histogram
  Z = Z[ which(is.finite(Z) ) ]
  u = try( density(Z ) , silent = TRUE )
  if ("try-error" %in% class(u) )  {
    res = data.frame( mode=NA, sd=NA, lb=NA, ub=NA,lb1=NA,ub1=NA,lb2=NA,ub2=NA )
    rownames(res) = c("simple")
    return(res)
  }

  dZ  = numDeriv::grad( approxfun( u$x, u$y, rule=2 ), u$x, method="simple" )
  dZsm = interpolate.xy.robust( dZ, method="loess")

  ddZ = numDeriv::grad( approxfun( u$x, dZsm, rule=2  ), u$x, method="simple" )
  ddZsm = interpolate.xy.robust( ddZ, method="loess")

  # inflection pts as lb, ub :: ddZ's maxima
  # peak1
  p1 = which.max( u$y )
  pl1 = which.max( dZsm )
  pr1 = which.min( dZsm )

  ddZ.med = median( ddZ)
  for ( p1lb in pl1:1) if ( ddZ[p1lb] >= eps ) break() # left
  for ( p1ub in pr1:length(ddZ) ) if ( ddZ[p1ub] >=  eps ) break() # right

      inflection.x = c( p1lb, p1ub )
      inflection.y = u$x[ inflection.x ]
      kd.mode = u$x[ p1 ]

  kd.sd0 = sd( Z[ Z > inflection.y[1] & Z < inflection.y[2] ] )

if(is.na(kd.sd0))   { #exception handling AMC Nov2.2015
  res = data.frame( cbind( mode=kd.mode, sd=NA, lb=NA, ub=NA,lb1=NA,ub1=NA,lb2=NA,ub2=NA ))
return(res)
}

  # expand the are of interest before computing SD
  ylb = inflection.y[1] - kd.sd0
  yub = inflection.y[2] + kd.sd0

  kd.sd = sd( Z[ Z > ylb & Z < yub ] )

  res = data.frame( cbind( mode=kd.mode, sd=kd.sd, lb=ylb, ub=yub ))
  rownames(res) = c("kerneldensity")

  res$ub1 = res$ub + res$sd
  res$lb1 = res$lb - res$sd

  res$ub2 = res$ub + 2*res$sd
  res$lb2 = res$lb - 2*res$sd

  return(res)
}


library(rgdal)    # for readOGR and others
library(sp)       # for spatial objects
library(leaflet)  # for interactive maps (NOT leafletR here)
library(dplyr)    # for working with data frames
library(ggplot2)  # for plotting
library(acs)

acs_vars<-load_variables(2017,"acs5", cache=TRUE)
View(acs_vars)

cd_115<- readOGR(dsn="examples/geofiles/us_legislative_districts", "cb_2017_us_cd115_500k")
cd_115@data$GEOID<-as.character(cd_115@data$GEOID)

MN_03_cd115 <- select(filter(cd_115@data, STATEFP == '27'),colnames(cd_115@data))

coordinates(AR_2018_06_upload) <- c("client_lon", "client_lat")
AR_cd115 <- subset(cd_115,STATEFP='05')
proj4string(AR_2018_06_upload) <- proj4string(cd_115)
AR2018_down <- cbind(AR2018_down,over(AR2018_down,AR_cd115))

#################
cd_115<- st_read(dsn="examples/geofiles/us_legislative_districts", layer="cb_2017_us_cd115_500k", quiet=TRUE)
AR_cd115 <- subset(cd_115,STATEFP='05')
AR_cd115_sp <- as(AR_cd115,"Spatial")
> (AR_geom <- st_geometry(AR_cd115))

######## cowork with Nick
library(tidyverse)