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

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

##############################################################
## US Census                                                ##
##############################################################

########################################
# Download complete data set from:
# https://www.census.gov/data/datasets/2016/demo/popest/counties-total.html

comp.cens.data <- function(){

  vals <- as.matrix(read.csv("co-est2016-alldata.csv", header=T))
  vals[,5] <- as.integer(vals[,5])
  vals <- vals[vals[,5]!=0,] #only leave county data

  return(vals)
}

########################################
cens.data <- function(census.data,ID){

  sequence <- as.numeric(census.data[,ID])

  # Convert to scientific notation
  sequence <- format(sequence,scientific=TRUE)

  return(sequence)
}

##############################################################
## Census Quick Facts                                       ##
##############################################################

########################################
# Download complete data set from:
# quickfacts.census.gov/qfd/download/DataSet.txt

comp.quick.data <- function(){

  vals <- as.matrix(read.csv("DataSet.txt", header=T))
  vals <- vals[vals[,1]%%1000!=0,] #only leave county data

  return(vals)
}

########################################
quick.data <- function(census.data,ID){

  sequence <- as.numeric(census.data[,ID])

  # Convert to scientific notation
  sequence <- format(sequence,scientific=TRUE)

  return(sequence)
}

##############################################################
## Stock Market                                             ##
##############################################################

########################################
comp.data <- function(mkt){

  vals <- as.matrix(read.csv(paste("http://online.wsj.com/public/resources/documents/",mkt,".csv",sep=""), header=T,skip=3))

  return(vals)
}

########################################
date.data <- function(){
  date1 <- as.matrix(read.csv("http://online.wsj.com/public/resources/documents/NYSE.csv",header=F,skip=1, nrows=1))
  date2 <- as.matrix(read.csv("http://online.wsj.com/public/resources/documents/Nasdaq.csv",header=F,skip=1, nrows=1))
  date3 <- as.matrix(read.csv("http://online.wsj.com/public/resources/documents/SCAP.csv",header=F,skip=1, nrows=1))
  date4 <- as.matrix(read.csv("http://online.wsj.com/public/resources/documents/AMEX.csv",header=F,skip=1, nrows=1))

  min.length <- min(nchar(date1),nchar(date2),nchar(date3),nchar(date4))

  if (nchar(date1)==min.length) return(date1)
  else if (nchar(date2)==min.length) return(date2)
  else if (nchar(date3)==min.length) return(date3)
  else if (nchar(date4)==min.length) return(date4)
}

##############################################################
## World Stock Market                                       ##
##############################################################

########################################
w.comp.data <- function(mkt){
  url <- paste("https://www.investing.com/indices/",mkt,sep="")

  #vals <- as.matrix(read.csv(paste("http://online.wsj.com/public/resources/documents/",mkt,".csv",sep=""), header=T,skip=3))

  vals <- url %>%
    read_html() %>%
    html_nodes(xpath='//*[@id="cr1"]') %>%
    html_table()

  vals <- vals[[1]]

  # Following line removes any "0 volume" stocks, but at
  # some points of the day volume can be 0 for all stocks
  # and that would lead to NO STOCKS READ
  #
  # vals<-vals[which(vals[,8]!=0),]

  return(vals)
}

########################################
w.status <- function(mkt){
  url <- paste("https://www.investing.com/indices/",mkt,sep="")

  my.status  <- url %>%
    read_html() %>%
    html_nodes(xpath='//*[@id="quotes_summary_current_data"]/div[1]/div[2]/div[2]/text()') %>%
    html_text()

  status <- "ACTIVE"
  if (length(grep("Closed",my.status[3]))) status <- "CLOSED"

  return(status)
}

########################################
seq.data <- function(all.data,var){

  # Use gsub() to remove embedded commas if any (for volume data)
  # Will not alter data without embedded commas (open, high, low, close)
  sequence <- as.numeric(gsub(",","",all.data[,var]))

  # Convert to scientific notation
  sequence <- format(sequence,scientific=TRUE)

  return(sequence)

}

########################################
goodness.test <- function(sequence){

  string <- substr(as.character(sequence),1,1)

  first.digits <- as.integer(string)

  # In the event any of the 9 possible digits is not observed in the string,
  # table(first.digits) will not display all digits 1, 2, ..., 9. An example is
  #
  # NAME     1  2  3  4  5  6  7  9
  # FREQ    12 11  9  8  6  5  4  2
  #
  # Here, obs <- as.integer(table(first.digits)) would only contain 8 elements.
  # To correct for this, initialize obs to a zero vector, loop through NAME,
  # find FREQ corresponding to NAME,then paste that FREQ in obs[NAME].
  # This will also work for the case when all 9 possible digits are observed.

  Obs <- seq(0,0,,9)

  for (i in as.numeric(names(table(first.digits))))  {
    pos <- which(as.numeric(names(table(first.digits)))==i)
    Obs[i]<- as.numeric(table(first.digits))[pos]
  }
  i <- seq(1,9)

  Exp <- sum(Obs)*log10(1+1/i)

  Digit <- seq(1,9)

  #print(info)

  chisq <- sum(((Obs-Exp)**2)/Exp)

  Exp <- round(Exp,3)
  info <- cbind(Digit,Obs,Exp)
  rownames(info)<-rep("",nrow(info))

  #print(chisq)

  p.value <- 1-pchisq(chisq,8)

  text.chi <- paste("Chi-Square=",format(round(chisq,3),nsmall=3),sep="")
  names(text.chi)<-""

  text.pval <- paste("P-Value=",format(round(p.value,3),nsmall=3),sep="")
  names(text.pval)<-""

  print(info)
  print(text.chi,quote=F)
  print(text.pval,quote=F)

}

############################################
pmf.compare<-function(sequence){

  string <- substr(as.character(sequence),1,1)

  first.digits <- as.integer(string)

  # In the event any of the 9 possible digits is not observed in the string,
  # table(first.digits) will not display all digits 1, 2, ..., 9. An example is
  #
  # NAME     1  2  3  4  5  6  7  9
  # FREQ    12 11  9  8  6  5  4  2
  #
  # Here, obs <- as.integer(table(first.digits)) would only contain 8 elements.
  # To correct for this, initialize obs to a zero vector, loop through NAME,
  # find FREQ corresponding to NAME,then paste that FREQ in obs[NAME].
  # This will also work for the case when all 9 possible digits are observed.

  Obs <- seq(0,0,,9)

  for (i in as.numeric(names(table(first.digits))))  {
    pos <- which(as.numeric(names(table(first.digits)))==i)
    Obs[i]<- as.numeric(table(first.digits))[pos]
  }
  i <- seq(1,9)

  pmf.Exp <- cbind(seq(1,9)+0.065,log10(1+1/i))
  pmf.Obs <- cbind(seq(1,9)-0.065,Obs/sum(Obs))

  col1 <- brewer.pal(n = 8, name = "Dark2")[6]
  col2 <- brewer.pal(n = 8, name = "Dark2")[1]

  par(mar=c(3.5,4.5,2,0))

  my.lwd <- 3.75

  if (max(pmf.Obs[,2])>=max(pmf.Exp[,2])){
    plot(pmf.Obs[,1],pmf.Obs[,2],type="n",col=col1,xlim=c(0.75,9.25),
         ylim=c(0,max(pmf.Obs[,2])),
         xlab="",ylab="Proportion", xaxt="n", main="Proportion of First Digits")
    axis(1, at=seq(1,9), labels=c("1","2","3","4","5","6","7","8","9"))
    mtext("First Digit",1,line=2.5)
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Obs[i,1],pmf.Obs[i,1]),c(0,pmf.Obs[i,2]),col=col1,lwd=my.lwd)
    }
    for (i in 1:nrow(pmf.Exp)){
      lines(c(pmf.Exp[i,1],pmf.Exp[i,1]),c(0,pmf.Exp[i,2]),col=col2,lwd=my.lwd)
      legend("topright", inset=.02,
             c("Observed Proportion","Benford's Law"), fill=c(col1,col2), horiz=F)
    }
  }

  if (max(pmf.Obs[,2])<max(pmf.Exp[,2])){
    plot(pmf.Exp[,1],pmf.Exp[,2],type="n",col=col2,xlim=c(0.75,9.25),
         ylim=c(0,max(pmf.Exp[,2])),
         xlab="", ylab="Proportion", xaxt="n", main="Proportion of First Digits")
    axis(1, at=seq(1,9), labels=c("1","2","3","4","5","6","7","8","9"))
    mtext("First Digit",1,line=2.5)
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Exp[i,1],pmf.Exp[i,1]),c(0,pmf.Exp[i,2]),col=col2,lwd=my.lwd)
    }
    for (i in 1:nrow(pmf.Obs)){
      lines(c(pmf.Obs[i,1],pmf.Obs[i,1]),c(0,pmf.Obs[i,2]),col=col1,lwd=my.lwd)
    }
    legend("topright", inset=.02,
           c("Observed Proportion","Benford's Law"), fill=c(col1,col2), horiz=F)
  }
}

##############################################################################
# Shiny Server Contents
##############################################################################

shinyServer(function(input, output, session) {

  #########################################################################
  ## Census I: Pop'n Estimates
  #########################################################################

  output$out.var.cens <- renderText({
      if (input$sel.var.cens==13) return("Resident Total Population Estimate 7/1/2013")
      if (input$sel.var.cens==14) return("Resident Total Population Estimate 7/1/2014")
      if (input$sel.var.cens==15) return("Resident Total Population Estimate 7/1/2015")
      if (input$sel.var.cens==16) return("Resident Total Population Estimate 7/1/2016")
      if (input$sel.var.cens==27) return("Births in Period 7/1/2012 to 6/30/2013")
      if (input$sel.var.cens==28) return("Births in Period 7/1/2013 to 6/30/2014")
      if (input$sel.var.cens==29) return("Births in Period 7/1/2014 to 6/30/2015")
      if (input$sel.var.cens==30) return("Births in Period 7/1/2015 to 6/30/2016")
      if (input$sel.var.cens==34) return("Deaths in Period 7/1/2012 to 6/30/2013")
      if (input$sel.var.cens==35) return("Deaths in Period 7/1/2013 to 6/30/2014")
      if (input$sel.var.cens==36) return("Deaths in Period 7/1/2014 to 6/30/2015")
      if (input$sel.var.cens==37) return("Deaths in Period 7/1/2015 to 6/30/2016")
      })

  complete.cens <- reactive({
    withProgress(message = 'Accessing Data', style = 'notification', value = 0.5, {
      Sys.sleep(.6)
      return(comp.cens.data())
    })
  })

  output$comp.rows.cens <- reactive({nrow(complete.cens())})

  data.seq.cens <- reactive({cens.data(complete.cens(),as.numeric(input$sel.var.cens))})

  output$goodness.cens <- renderPrint({
    withProgress(message = 'Performing Goodness of Fit', style = 'notification', value = 0.75, {
      Sys.sleep(0.6)
      goodness.test(data.seq.cens())
    })
  })

  output$cens.pmf <- renderPlot({
    withProgress(message = 'Generating Plot', style = 'notification', value = 1, {
      Sys.sleep(0.6)
      pmf.compare(data.seq.cens())
    })
  })

  #########################################################################
  ## Census II: Quick Data
  #########################################################################

  output$out.var.quick <- renderText({
      if (input$sel.var.quick==25) return("Housing Units, 2013")
      if (input$sel.var.quick==29) return("Households, 2008-12")
      if (input$sel.var.quick==23) return("Veterans, 2008-12")
      if (input$sel.var.quick==37) return("Nonemployer Establishments, 2012")
      if (input$sel.var.quick==34) return("*Private Nonfarm Establishments, 2012")
      if (input$sel.var.quick==35) return("*Private Nonfarm Employment, 2012")
      if (input$sel.var.quick==47) return("*Retail Sales, 2007 ($1000)")
      })

  complete.quick <- reactive({
    withProgress(message = 'Accessing Data', style = 'notification', value = 0.5, {
      Sys.sleep(.6)
      return(comp.quick.data())
    })
  })

  output$comp.rows.quick <- reactive({nrow(complete.quick())})

  data.seq.quick <- reactive({quick.data(complete.quick(),as.numeric(input$sel.var.quick))})

  output$goodness.quick <- renderPrint({
    withProgress(message = 'Performing Goodness of Fit', style = 'notification', value = 0.75, {
      Sys.sleep(0.6)
      goodness.test(data.seq.quick())
    })
  })

  output$quick.pmf <- renderPlot({
    withProgress(message = 'Generating Plot', style = 'notification', value = 1, {
      Sys.sleep(0.6)
      pmf.compare(data.seq.quick())
    })
  })

  #########################################################################
  ## US Stock Market                                                     ##
  #########################################################################

  output$out.var <- renderText({
    if (input$sel.var==9) return("Volume of Shares Traded")
    if (input$sel.var==3) return("Opening Price")
    if (input$sel.var==4) return("High Price")
    if (input$sel.var==5) return("Low Price")
    if (input$sel.var==6) return("Closing Price")
  })

  output$param.stock <- renderText({
    if (input$stock == "New York Stock Exchange") return("NYSE")
    if (input$stock == "Nasdaq Stock Market") return("Nasdaq")
    if (input$stock == "Nasdaq Capital Market") return("SCAP")
    if (input$stock == "NYSE MKT Stock Exchange") return("AMEX")
  })

  output$short.stock <- renderText({
    if (input$stock == "New York Stock Exchange") return("NYSE")
    if (input$stock == "Nasdaq Stock Market") return("Nasdaq")
    if (input$stock == "Nasdaq Capital Market") return("Nasdaq Cap")
    if (input$stock == "NYSE MKT Stock Exchange") return("NYSE MKT")
  })

  complete <- reactive({
    if (input$stock == "New York Stock Exchange") mkt <- "NYSE"
    if (input$stock == "Nasdaq Stock Market")     mkt <- "Nasdaq"
    if (input$stock == "Nasdaq Capital Market")   mkt <- "SCAP"
    if (input$stock == "NYSE MKT Stock Exchange") mkt <- "AMEX"
    withProgress(message = 'Accessing Data', style = 'notification', value = 0.5, {
    return(comp.data(mkt))
    })
  })

  output$comp.date <- renderText({
    return(date.data())
  })

  output$comp.rows <- reactive({nrow(complete())})

  data.seq <- reactive({seq.data(complete(),as.numeric(input$sel.var))})

  output$goodness <- renderPrint({
    withProgress(message = 'Performing Goodness of Fit', style = 'notification', value = 0.75, {
      Sys.sleep(0.6)
      goodness.test(data.seq())
    })
  })

  output$stock.pmf <- renderPlot({
    withProgress(message = 'Generating Plot', style = 'notification', value = 1, {
      Sys.sleep(0.6)
      pmf.compare(data.seq())
    })
  })

  #########################################################################
  ## World Stock Market
  #########################################################################

  output$w.out.var <- renderText({
      if (input$w.sel.var==3) return("Most Recent Price")
      if (input$w.sel.var==4) return("High Price")
      if (input$w.sel.var==5) return("Low Price")
      })

  UTC.time <- as.POSIXct(Sys.time(), format="%m/%d/%Y %H:%M:%S")
  attr(UTC.time,"tzone")<-"UTC"

  output$w.time.stock <- renderText({
    if(input$w.stock == "Australia")   return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Canada")      return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "China")       return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Denmark")     return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "England")     return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "France")      return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Germany")     return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "India")       return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Japan")       return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Korea")       return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Netherlands") return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Poland")      return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Sri Lanka")   return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Switzerland") return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))
    if(input$w.stock == "Turkey")      return(paste(toupper(format(UTC.time, "%Y%b%d"))," -- ",toupper(format(UTC.time, "%H:%M:%S %Z")),sep=""))  })

  output$USA.icon.stock <- renderImage({
    return(list(src=normalizePath(file.path('./flags',paste('USA.png', sep=''))),height=24))
  },deleteFile=FALSE)

    output$w.icon.stock <- renderImage({
    if(input$w.stock == "Australia")   return(list(src=normalizePath(file.path('./flags',paste('AUS.png', sep=''))),height=24))
    if(input$w.stock == "Canada")      return(list(src=normalizePath(file.path('./flags',paste('CAN.png', sep=''))),height=24))
    if(input$w.stock == "China")       return(list(src=normalizePath(file.path('./flags',paste('CHN.png', sep=''))),height=24))
    if(input$w.stock == "Denmark")     return(list(src=normalizePath(file.path('./flags',paste('DEN.png', sep=''))),height=24))
    if(input$w.stock == "England")     return(list(src=normalizePath(file.path('./flags',paste('ENG.png', sep=''))),height=24))
    if(input$w.stock == "France")      return(list(src=normalizePath(file.path('./flags',paste('FRA.png', sep=''))),height=24))
    if(input$w.stock == "Germany")     return(list(src=normalizePath(file.path('./flags',paste('GER.png', sep=''))),height=24))
    if(input$w.stock == "India")       return(list(src=normalizePath(file.path('./flags',paste('IND.png', sep=''))),height=24))
    if(input$w.stock == "Japan")       return(list(src=normalizePath(file.path('./flags',paste('JPN.png', sep=''))),height=24))
    if(input$w.stock == "Korea")       return(list(src=normalizePath(file.path('./flags',paste('KOR.png', sep=''))),height=24))
    if(input$w.stock == "Netherlands") return(list(src=normalizePath(file.path('./flags',paste('NET.png', sep=''))),height=24))
    if(input$w.stock == "Poland")      return(list(src=normalizePath(file.path('./flags',paste('POL.png', sep=''))),height=24))
    if(input$w.stock == "Sri Lanka")   return(list(src=normalizePath(file.path('./flags',paste('SRI.png', sep=''))),height=24))
    if(input$w.stock == "Switzerland") return(list(src=normalizePath(file.path('./flags',paste('SWI.png', sep=''))),height=24))
    if(input$w.stock == "Turkey")      return(list(src=normalizePath(file.path('./flags',paste('TUR.png', sep=''))),height=24))
    },deleteFile=FALSE)

  output$w.curr.stock <- renderText({
    if(input$w.stock == "Australia")   return("AUD")
    if(input$w.stock == "Canada")      return("CAD")
    if(input$w.stock == "China")       return("CNY")
    if(input$w.stock == "Denmark")     return("DKK")
    if(input$w.stock == "England")     return("GBP")
    if(input$w.stock == "France")      return("EUR")
    if(input$w.stock == "Germany")     return("EUR")
    if(input$w.stock == "India")       return("INR")
    if(input$w.stock == "Japan")       return("JPY")
    if(input$w.stock == "Korea")       return("KRW")
    if(input$w.stock == "Netherlands") return("EUR")
    if(input$w.stock == "Poland")      return("PLN")
    if(input$w.stock == "Sri Lanka")   return("LKR")
    if(input$w.stock == "Switzerland") return("CHF")
    if(input$w.stock == "Turkey")      return("TRY")  })

  output$USA.curr.stock <- renderText({
    return("USD")})

    output$w.short.stock <- renderText({
    if(input$w.stock == "Australia")   return("S&P/ASX 200 (AXJO)")
    if(input$w.stock == "Canada")      return("S&P/TSX Comp (GSPTSE)")
    if(input$w.stock == "China")       return("SZSE Component (SZSC1)")
    if(input$w.stock == "Denmark")     return("OMX Copenhagen (OMXCGI)")
    if(input$w.stock == "England")     return("FTSE 350 (FTLC)")
    if(input$w.stock == "France")      return("CAC All Shares (PAX)")
    if(input$w.stock == "Germany")     return("Classic All Share (CLALL)")
    if(input$w.stock == "India")       return("S&P BSE-500 (BSE500)")
    if(input$w.stock == "Japan")       return("Nikkei 225 (N225)")
    if(input$w.stock == "Korea")       return("KOSPI (KS11)")
    if(input$w.stock == "Netherlands") return("Next 150 (N150)")
    if(input$w.stock == "Poland")      return("WIG (WIG)")
    if(input$w.stock == "Sri Lanka")   return("CSE All-Share (CSE)")
    if(input$w.stock == "Switzerland") return("Swiss All Share (SSIR)")
    if(input$w.stock == "Turkey")      return("BIST 100 (XU100)")
  })

  w.complete <- reactive({
    if(input$w.stock == "Australia")   w.mkt <- "aus-200-components"
    if(input$w.stock == "Canada")      w.mkt <- "s-p-tsx-composite-components"
    if(input$w.stock == "China")       w.mkt <- "szse-component-components"
    if(input$w.stock == "Denmark")     w.mkt <- "omx-copenhagen-all-shares-components"
    if(input$w.stock == "England")     w.mkt <- "ftse-350-components"
    if(input$w.stock == "France")      w.mkt <- "cac-allshares-components"
    if(input$w.stock == "Germany")     w.mkt <- "classic-all-share-components"
    if(input$w.stock == "India")       w.mkt <- "s-p-bse-500-components"
    if(input$w.stock == "Japan")       w.mkt <- "japan-ni225-components"
    if(input$w.stock == "Korea")       w.mkt <- "kospi-components"
    if(input$w.stock == "Netherlands") w.mkt <- "next-150-index-components"
    if(input$w.stock == "Poland")      w.mkt <- "wig-components"
    if(input$w.stock == "Sri Lanka")   w.mkt <- "cse-all-share-components"
    if(input$w.stock == "Switzerland") w.mkt <- "swiss-allshare-components"
    if(input$w.stock == "Turkey")      w.mkt <- "ise-100-components"
    withProgress(message = 'Accessing Data', style = 'notification', value = 0.5, {
    return(w.comp.data(w.mkt))
    })
  })

  output$w.mkt.status <- reactive({
    if(input$w.stock == "Australia")   w.mkt <- "aus-200-components"
    if(input$w.stock == "Canada")      w.mkt <- "s-p-tsx-composite-components"
    if(input$w.stock == "China")       w.mkt <- "szse-component-components"
    if(input$w.stock == "Denmark")     w.mkt <- "omx-copenhagen-all-shares-components"
    if(input$w.stock == "England")     w.mkt <- "ftse-350-components"
    if(input$w.stock == "France")      w.mkt <- "cac-allshares-components"
    if(input$w.stock == "Germany")     w.mkt <- "classic-all-share-components"
    if(input$w.stock == "India")       w.mkt <- "s-p-bse-500-components"
    if(input$w.stock == "Japan")       w.mkt <- "japan-ni225-components"
    if(input$w.stock == "Korea")       w.mkt <- "kospi-components"
    if(input$w.stock == "Netherlands") w.mkt <- "next-150-index-components"
    if(input$w.stock == "Poland")      w.mkt <- "wig-components"
    if(input$w.stock == "Sri Lanka")   w.mkt <- "cse-all-share-components"
    if(input$w.stock == "Switzerland") w.mkt <- "swiss-allshare-components"
    if(input$w.stock == "Turkey")      w.mkt <- "ise-100-components"
    withProgress(message = 'Accessing Market Status', style = 'notification', value = 0.25, {
                  return(w.status(w.mkt))
    })
  })

  output$w.comp.rows <- reactive({nrow(w.complete())})

  w.data.seq <- reactive({seq.data(w.complete(),as.numeric(input$w.sel.var))})

  output$w.goodness <- renderPrint({
    withProgress(message = 'Performing Goodness of Fit', style = 'notification', value = 0.75, {
      Sys.sleep(0.6)
      goodness.test(w.data.seq())
    })
  })

  output$w.stock.pmf <- renderPlot({
    withProgress(message = 'Generating Plot', style = 'notification', value = 1, {
      Sys.sleep(0.6)
      pmf.compare(w.data.seq())
    })
  })

})#close shinyServer


                                   CCHHAAPPTTEERR  77

                                TThhee LLiisspp RReeaaddeerr

             77..11..  IInnttrroodduuccttiioonn

                     The _r_e_a_d function is responsible for converting a
                stream of characters into a Lisp expression.  _R_e_a_d  is
                table  driven  and  the  table  it  uses  is  called a
                _r_e_a_d_t_a_b_l_e_.  The _p_r_i_n_t function  does  the  inverse  of
                _r_e_a_d;  it  converts a Lisp expression into a stream of
                characters.  Typically the conversion is done in  such
                a  way  that if that stream of characters were read by
                _r_e_a_d, the result would be an expression equal  to  the
                one  _p_r_i_n_t  was  given.   _P_r_i_n_t must also refer to the
                readtable in order to determine how to format its out-
                put.   The  _e_x_p_l_o_d_e  function, which returns a list of
                characters rather than printing them,  must also refer
                to the readtable.

                     A  readtable  is  created  with the _m_a_k_e_r_e_a_d_t_a_b_l_e
                function, modified with  the  _s_e_t_s_y_n_t_a_x  function  and
                interrogated  with the _g_e_t_s_y_n_t_a_x function.  The struc-
                ture of a readtable is  hidden  from  the  user   -  a
                readtable  should  only  be manipulated with the three
                functions mentioned above.

                     There is one distinguished readtable  called  the
                _c_u_r_r_e_n_t  _r_e_a_d_t_a_b_l_e  whose  value determines what _r_e_a_d,
                _p_r_i_n_t and _e_x_p_l_o_d_e do.  The current  readtable  is  the
                value  of  the symbol _r_e_a_d_t_a_b_l_e.  Thus it is  possible
                to rapidly change the current syntax by lambda binding
                a  different  readtable to the symbol _r_e_a_d_t_a_b_l_e_.  When
                the binding is undone, the syntax reverts to  its  old
                form.

             77..22..  SSyynnttaaxx CCllaasssseess

                     The readtable describes how each of the 128 ascii
                characters  should  be  treated  by  the  reader   and
                printer.   Each  character  belongs  to a _s_y_n_t_a_x _c_l_a_s_s
                which has three properties:

                character class -
                     Tells what the reader should do when it sees this

          TThhee LLiisspp RReeaaddeerr                                          77--11

          TThhee LLiisspp RReeaaddeerr                                          77--22

                     character.  There are a large number of character
                     classes.  They are described below.

                separator -
                     Most types of tokens the  reader  constructs  are
                     one  character  long.   Four  token types have an
                     arbitrary length:  number  (1234),  symbol  print
                     name   (franz),   escaped   symbol   print   name
                     (|franz|), and string ("franz").  The reader  can
                     easily  determine  when it has come to the end of
                     one of the last two types: it just looks for  the
                     matching  delimiter (| or ").  When the reader is
                     reading a number or symbol print name,  it  stops
                     reading  when  it  comes  to a character with the
                     _s_e_p_a_r_a_t_o_r property.  The separator  character  is
                     pushed back into the input stream and will be the
                     first character read when the  reader  is  called
                     again.

                escape -
                     Tells  the  printer  when to put escapes in front
                     of, or around, a symbol whose print name contains
                     this  character.   There are three possibilities:
                     always escape a symbol with this character in it,
                     only  escape a symbol if this is the only charac-
                     ter in the symbol, and only escape  a  symbol  if
                     this  is  the  first  character  in  the  symbol.
                     [note: The printer will always  escape  a  symbol
                     which,  if  printed  out, would look like a valid
                     number.]

                     When the Lisp system is built, Lisp code is added
                to  a  C-coded kernel and the result becomes the stan-
                dard lisp system.  The readtable  present  in  the  C-
                coded  kernel,  called the _r_a_w _r_e_a_d_t_a_b_l_e, contains the
                bare necessities for reading in Lisp code.  During the
                construction  of  the  complete Lisp system, a copy is
                made of the raw readtable and then the copy  is  modi-
                fied  by  adding macro characters.  The result is what
                is  called  the  _s_t_a_n_d_a_r_d  _r_e_a_d_t_a_b_l_e.   When   a   new
                readtable  is  created  with  _m_a_k_e_r_e_a_d_t_a_b_l_e_, a copy is
                made of  either  the  raw  readtable  or  the  current
                readtable   (which   is  likely  to  be  the  standard
                readtable).

             77..33..  RReeaaddeerr OOppeerraattiioonnss

                     The reader has a very simple  algorithm.   It  is
                either  _s_c_a_n_n_i_n_g  for  a token, _c_o_l_l_e_c_t_i_n_g a token, or
                _p_r_o_c_e_s_s_i_n_g a token.  Scanning involves reading charac-
                ters  and throwing away those which don't start tokens

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                          77--33

                (such as blanks and tabs).  Collecting means gathering
                the  characters  which  make up a token into a buffer.
                Processing  may  involve  creating  symbols,  strings,
                lists,  fixnums,  bignums or flonums or calling a user
                written function called a character macro.

                     The components of the syntax class determine when
                the  reader  switches between the scanning, collecting
                and processing states.  The reader will continue scan-
                ning  as long as the character class of the characters
                it reads is _c_s_e_p_a_r_a_t_o_r_.  When  it  reads  a  character
                whose character class is not _c_s_e_p_a_r_a_t_o_r it stores that
                character in its  buffer  and  begins  the  collecting
                phase.

                     If the character class of that first character is
                _c_c_h_a_r_a_c_t_e_r, _c_n_u_m_b_e_r, _c_p_e_r_i_o_d, or _c_s_i_g_n.  then it  will
                continue  collecting  until  it  runs into a character
                whose syntax class has the _s_e_p_a_r_a_t_o_r property.   (That
                last  character  will  be  pushed  back into the input
                buffer and will  be  the  first  character  read  next
                time.)  Now the reader goes into the processing phase,
                checking to see if the token it read is  a  number  or
                symbol.  It is important to note that  after the first
                character is collected the  component  of  the  syntax
                class  which  tells  the reader to  stop collecting is
                the _s_e_p_a_r_a_t_o_r property, not the character class.

                     If the character class  of  the  character  which
                stopped  the scanning is not _c_c_h_a_r_a_c_t_e_r, _c_n_u_m_b_e_r, _c_p_e_-
                _r_i_o_d, or _c_s_i_g_n.  then the reader processes that  char-
                acter  immediately.   The  character  classes _c_s_i_n_g_l_e_-
                _m_a_c_r_o, _c_s_i_n_g_l_e_-_s_p_l_i_c_i_n_g_-_m_a_c_r_o, and _c_s_i_n_g_l_e_-_i_n_f_i_x_-_m_a_c_r_o
                will act like _c_c_h_a_r_a_c_t_e_r if the following token is not
                a _s_e_p_a_r_a_t_o_r_.  The processing which is done for a given
                character  class  is  described  in detail in the next
                section.

             77..44..  CChhaarraacctteerr CCllaasssseess

          _c_c_h_a_r_a_c_t_e_r    raw readtable:A-Z a-z ^H !#$%&*,/:;<=>?@^_`{}~
                      standard readtable:A-Z a-z ^H !$%&*/:;<=>?@^_{}~
                A normal character.

          _c_n_u_m_b_e_r                                    raw readtable:0-9
                                                standard readtable:0-9
                This type is a  digit.   The  syntax  for  an  integer
                (fixnum  or  bignum) is a string of _c_n_u_m_b_e_r characters
                optionally followed by a _c_p_e_r_i_o_d_.  If the  digits  are

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                          77--44

                not  followed  by a _c_p_e_r_i_o_d, then they are interpreted
                in base _i_b_a_s_e which must be eight or ten.  The  syntax
                for  a  floating  point  number is either zero or more
                _c_n_u_m_b_e_r's followed by a _c_p_e_r_i_o_d and then  followed  by
                one  or  more  _c_n_u_m_b_e_r's.  A floating point number may
                also be  an integer or floating point number  followed
                by 'e' or 'd', an optional '+' or '-' and then zero or
                more _c_n_u_m_b_e_r's.

          _c_s_i_g_n                                       raw readtable:+-
                                                 standard readtable:+-
                A leading sign for  a  number.   No  other  characters
                should be given this class.

          _c_l_e_f_t_-_p_a_r_e_n                                  raw readtable:(
                                                  standard readtable:(
                A left parenthesis.  Tells the reader to begin forming
                a list.

          _c_r_i_g_h_t_-_p_a_r_e_n                                 raw readtable:)
                                                  standard readtable:)
                A right parenthesis.  Tells the  reader  that  it  has
                reached the end of a list.

          _c_l_e_f_t_-_b_r_a_c_k_e_t                                raw readtable:[
                                                  standard readtable:[
                A left bracket.  Tells the reader that it should begin
                forming a list.  See the description of _c_r_i_g_h_t_-_b_r_a_c_k_e_t
                for  the  difference  between cleft-bracket and cleft-
                paren.

          _c_r_i_g_h_t_-_b_r_a_c_k_e_t                               raw readtable:]
                                                  standard readtable:]
                A right bracket.  A _c_r_i_g_h_t_-_b_r_a_c_k_e_t finishes the forma-
                tion of the current list and all enclosing lists until
                it finds one which  begins  with  a  _c_l_e_f_t_-_b_r_a_c_k_e_t  or
                until it reaches the top level list.

          _c_p_e_r_i_o_d                                      raw readtable:.
                                                  standard readtable:.
                The  period is used to separate element of a cons cell
                [e.g. (a . (b . nil)) is the same as (a b)].   _c_p_e_r_i_o_d
                is also used in numbers as described above.

          _c_s_e_p_a_r_a_t_o_r                     raw readtable:^I-^M esc space
                                    standard readtable:^I-^M esc space

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                          77--55

                Separates  tokens.  When the reader is scanning, these
                character are passed over.  Note: there is  a  differ-
                ence  between  the  _c_s_e_p_a_r_a_t_o_r character class and the
                _s_e_p_a_r_a_t_o_r property of a syntax class.

          _c_s_i_n_g_l_e_-_q_u_o_t_e                                raw readtable:'
                                                  standard readtable:'
                This causes _r_e_a_d to be called recursively and the list
                (quote <value read>) to be returned.

          _c_s_y_m_b_o_l_-_d_e_l_i_m_i_t_e_r                            raw readtable:|
                                                  standard readtable:|
                This  causes the reader to begin collecting characters
                and to  stop  only  when  another  identical  _c_s_y_m_b_o_l_-
                _d_e_l_i_m_i_t_e_r  is seen.  The only way to escape a _c_s_y_m_b_o_l_-
                _d_e_l_i_m_i_t_e_r within a symbol name is with a _c_e_s_c_a_p_e char-
                acter.   The collected characters are converted into a
                string which becomes the print name of a symbol.  If a
                symbol  with  an  identical print name already exists,
                then the allocation is not done, rather  the  existing
                symbol is used.

          _c_e_s_c_a_p_e                                      raw readtable:\
                                                  standard readtable:\
                This  causes  the  next  character  to  read  in to be
                treated as a vvcchhaarraacctteerr.   A  character  whose  syntax
                class  is  vvcchhaarraacctteerr has a character class _c_c_h_a_r_a_c_t_e_r
                and does not have the _s_e_p_a_r_a_t_o_r property  so  it  will
                not separate symbols.

          _c_s_t_r_i_n_g_-_d_e_l_i_m_i_t_e_r                            raw readtable:"
                                                  standard readtable:"
                This  is  the  same  as  _c_s_y_m_b_o_l_-_d_e_l_i_m_i_t_e_r  except the
                result is returned as a string instead of a symbol.

          _c_s_i_n_g_l_e_-_c_h_a_r_a_c_t_e_r_-_s_y_m_b_o_l                  raw readtable:none
                                               standard readtable:none
                This returns a symbol whose print name is the the sin-
                gle character which has been collected.

          _c_m_a_c_r_o                                    raw readtable:none
                                                 standard readtable:`,
                The  reader  calls  the macro function associated with
                this character and the current readtable,  passing  it
                no arguments.  The result of the macro is added to the
                structure the reader is building, just as if that form
                were  directly  read  by  the reader.  More details on

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                          77--66

                macros are provided below.

          _c_s_p_l_i_c_i_n_g_-_m_a_c_r_o                           raw readtable:none
                                                 standard readtable:#;
                A _c_s_p_l_i_c_i_n_g_-_m_a_c_r_o differs from a _c_m_a_c_r_o in the way the
                result  is incorporated in the structure the reader is
                building.  A _c_s_p_l_i_c_i_n_g_-_m_a_c_r_o must  return  a  list  of
                forms (possibly empty).  The reader acts as if it read
                each element of the list itself without the  surround-
                ing parenthesis.

          _c_s_i_n_g_l_e_-_m_a_c_r_o                             raw readtable:none
                                               standard readtable:none
                This causes to reader to check the next character.  If
                it is a _c_s_e_p_a_r_a_t_o_r then this acts like a _c_m_a_c_r_o_.  Oth-
                erwise, it acts like a _c_c_h_a_r_a_c_t_e_r_.

          _c_s_i_n_g_l_e_-_s_p_l_i_c_i_n_g_-_m_a_c_r_o                    raw readtable:none
                                               standard readtable:none
                This  is  triggered  like  a _c_s_i_n_g_l_e_-_m_a_c_r_o however the
                result is spliced in like a _c_s_p_l_i_c_i_n_g_-_m_a_c_r_o_.

          _c_i_n_f_i_x_-_m_a_c_r_o                              raw readtable:none
                                               standard readtable:none
                This is differs from a _c_m_a_c_r_o in that the macro  func-
                tion is passed a form representing what the reader has
                read so far.  The result of the  macro  replaces  what
                the reader had read so far.

          _c_s_i_n_g_l_e_-_i_n_f_i_x_-_m_a_c_r_o                       raw readtable:none
                                               standard readtable:none
                This  differs  from the _c_i_n_f_i_x_-_m_a_c_r_o in that the macro
                will only be triggered if the character following  the
                _c_s_i_n_g_l_e_-_i_n_f_i_x_-_m_a_c_r_o character is a _c_s_e_p_a_r_a_t_o_r.

          _c_i_l_l_e_g_a_l                 raw readtable:^@-^G^N-^Z^\-^_rubout
                              standard readtable:^@-^G^N-^Z^\-^_rubout
                The  characters cause the reader to signal an error if
                read.

             77..55..  SSyynnttaaxx CCllaasssseess

                     The readtable maps each character into  a  syntax
                class.   The  syntax  class  contains  three pieces of
                information: the character class, whether  this  is  a

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                          77--77

                separator,  and  the escape properties.  The first two
                properties are used by the reader,  the  last  by  the
                printer  (and  _e_x_p_l_o_d_e).   The initial lisp system has
                the following syntax classes defined.   The  user  may
                add  syntax  classes  with _a_d_d_-_s_y_n_t_a_x_-_c_l_a_s_s.  For each
                syntax class, we list the properties of the class  and
                which  characters  have  this syntax class by default.
                More information about each syntax class can be  found
                under  the description of the syntax class's character
                class.

          vvcchhaarraacctteerr    raw readtable:A-Z a-z ^H !#$%&*,/:;<=>?@^_`{}~
          _c_c_h_a_r_a_c_t_e_r  standard readtable:A-Z a-z ^H !$%&*/:;<=>?@^_{}~

          vvnnuummbbeerr                                    raw readtable:0-9
          _c_n_u_m_b_e_r                               standard readtable:0-9

          vvssiiggnn                                       raw readtable:+-
          _c_s_i_g_n                                  standard readtable:+-

          vvlleefftt--ppaarreenn                                  raw readtable:(
          _c_l_e_f_t_-_p_a_r_e_n                             standard readtable:(
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

          vvrriigghhtt--ppaarreenn                                 raw readtable:)
          _c_r_i_g_h_t_-_p_a_r_e_n                            standard readtable:)
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

          vvlleefftt--bbrraacckkeett                                raw readtable:[
          _c_l_e_f_t_-_b_r_a_c_k_e_t                           standard readtable:[
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

          vvrriigghhtt--bbrraacckkeett                               raw readtable:]
          _c_r_i_g_h_t_-_b_r_a_c_k_e_t                          standard readtable:]
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

          vvppeerriioodd                                      raw readtable:.
          _c_p_e_r_i_o_d                                 standard readtable:.
          _e_s_c_a_p_e_-_w_h_e_n_-_u_n_i_q_u_e

          vvsseeppaarraattoorr                     raw readtable:^I-^M esc space
          _c_s_e_p_a_r_a_t_o_r                standard readtable:^I-^M esc space

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                          77--88

          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

          vvssiinnggllee--qquuoottee                                raw readtable:'
          _c_s_i_n_g_l_e_-_q_u_o_t_e                           standard readtable:'
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

          vvssyymmbbooll--ddeelliimmiitteerr                            raw readtable:|
          _c_s_i_n_g_l_e_-_d_e_l_i_m_i_t_e_r                       standard readtable:|
          _e_s_c_a_p_e_-_a_l_w_a_y_s

          vveessccaappee                                      raw readtable:\
          _c_e_s_c_a_p_e                                 standard readtable:\
          _e_s_c_a_p_e_-_a_l_w_a_y_s

          vvssttrriinngg--ddeelliimmiitteerr                            raw readtable:"
          _c_s_t_r_i_n_g_-_d_e_l_i_m_i_t_e_r                       standard readtable:"
          _e_s_c_a_p_e_-_a_l_w_a_y_s

          vvssiinnggllee--cchhaarraacctteerr--ssyymmbbooll                  raw readtable:none
          _c_s_i_n_g_l_e_-_c_h_a_r_a_c_t_e_r_-_s_y_m_b_o_l             standard readtable:none
          _s_e_p_a_r_a_t_o_r

          vvmmaaccrroo                                    raw readtable:none
          _c_m_a_c_r_o                                 standard readtable:`,
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

          vvsspplliicciinngg--mmaaccrroo                           raw readtable:none
          _c_s_p_l_i_c_i_n_g_-_m_a_c_r_o                        standard readtable:#;
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

          vvssiinnggllee--mmaaccrroo                             raw readtable:none
          _c_s_i_n_g_l_e_-_m_a_c_r_o                        standard readtable:none
          _e_s_c_a_p_e_-_w_h_e_n_-_u_n_i_q_u_e

          vvssiinnggllee--sspplliicciinngg--mmaaccrroo                    raw readtable:none
          _c_s_i_n_g_l_e_-_s_p_l_i_c_i_n_g_-_m_a_c_r_o               standard readtable:none
          _e_s_c_a_p_e_-_w_h_e_n_-_u_n_i_q_u_e

          vviinnffiixx--mmaaccrroo                              raw readtable:none
          _c_i_n_f_i_x_-_m_a_c_r_o                         standard readtable:none
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                          77--99

          vvssiinnggllee--iinnffiixx--mmaaccrroo                       raw readtable:none
          _c_s_i_n_g_l_e_-_i_n_f_i_x_-_m_a_c_r_o                  standard readtable:none
          _e_s_c_a_p_e_-_w_h_e_n_-_u_n_i_q_u_e

          vviilllleeggaall                 raw readtable:^@-^G^N-^Z^\-^_rubout
          _c_i_l_l_e_g_a_l            standard readtable:^@-^G^N-^Z^\-^_rubout
          _e_s_c_a_p_e_-_a_l_w_a_y_s
          _s_e_p_a_r_a_t_o_r

             77..66..  CChhaarraacctteerr MMaaccrrooss

                     Character macros are user written functions which
                are  executed  during  the reading process.  The value
                returned by a character macro may or may not  be  used
                by  the reader, depending on the type of macro and the
                value returned.  Character macros are always  attached
                to a single character with the _s_e_t_s_y_n_t_a_x function.

                77..66..11..   TTyyppeess    There  are  three types of character
                   macros: normal, splicing and  infix.   These  types
                   differ  in  the arguments they are given or in what
                   is done with the result they return.

                   77..66..11..11..  NNoorrmmaall

                           A normal macro is passed no arguments.  The
                      value  returned by a normal macro is simply used
                      by the reader  as  if  it  had  read  the  value
                      itself.   Here  is  an  example of a macro which
                      returns the abbreviation for a given state.

              ____________________________________________________

              ->_(_d_e_f_u_n _s_t_a_t_e_a_b_b_r_e_v _n_i_l
                    _(_c_d_r _(_a_s_s_q _(_r_e_a_d_) _'_(_(_c_a_l_i_f_o_r_n_i_a _. _c_a_) _(_p_e_n_n_s_y_l_v_a_n_i_a _. _p_a_)_)_)_)_)
              stateabbrev
              -> _(_s_e_t_s_y_n_t_a_x _'_\_! _'_v_m_a_c_r_o _'_s_t_a_t_e_a_b_b_r_e_v_)
              t
              -> _'_( _! _c_a_l_i_f_o_r_n_i_a _! _w_y_o_m_i_n_g _! _p_e_n_n_s_y_l_v_a_n_i_a_)
              (ca nil pa)
              ____________________________________________________

          Notice what happened to

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                         77--1100

           _! _w_y_o_m_i_n_g.  Since it wasn't in the  table,  the  associated
          function  returned  nil.   The creator of the macro may have
          wanted to leave the list alone, in such a case, but couldn't
          with  this  type  of  reader  macro.   The  splicing  macro,
          described next, allows a character macro function to  return
          a value that is ignored.

                   77..66..11..22..  SSpplliicciinngg

                           The  value  returned  from a splicing macro
                      must be a list or nil.  If  the  value  is  nil,
                      then  the value is ignored, otherwise the reader
                      acts as if it read  each  object  in  the  list.
                      Usually  the list only contains one element.  If
                      the reader is reading at the top level (i.e. not
                      collecting elements of list), then it is illegal
                      for a splicing macro to  return  more  then  one
                      element  in  the list.  The major advantage of a
                      splicing macro over a normal macro is the  abil-
                      ity  of  the  splicing  macro to return nothing.
                      The comment character (usually ;) is a  splicing
                      macro bound to a function which reads to the end
                      of the line and always returns nil.  Here is the
                      previous example written as a splicing macro

              ____________________________________________________

              -> _(_d_e_f_u_n _s_t_a_t_e_a_b_b_r_e_v _n_i_l
                    _(_(_l_a_m_b_d_a _(_v_a_l_u_e_)
                          _(_c_o_n_d _(_v_a_l_u_e _(_l_i_s_t _v_a_l_u_e_)_)
                                 _(_t _n_i_l_)_)_)
                      _(_c_d_r _(_a_s_s_q _(_r_e_a_d_) _'_(_(_c_a_l_i_f_o_r_n_i_a _. _c_a_) _(_p_e_n_n_s_y_l_v_a_n_i_a _. _p_a_)_)_)_)_)_)
              -> _(_s_e_t_s_y_n_t_a_x _'_! _'_v_s_p_l_i_c_i_n_g_-_m_a_c_r_o _'_s_t_a_t_e_a_b_b_r_e_v_)
              -> _'_(_!_p_e_n_n_s_y_l_v_a_n_i_a _! _f_o_o _!_c_a_l_i_f_o_r_n_i_a_)
              (pa ca)
              -> _'_!_f_o_o _!_b_a_r _!_p_e_n_n_s_y_l_v_a_n_i_a
              pa
              ->
              ____________________________________________________

                   77..66..11..33..  IInnffiixx

                           Infix  macros  are  passed a _c_o_n_c structure
                      representing  what  has  been   read   so   far.
                      Briefly, a tconc structure is a single list cell

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                         77--1111

                      whose car points to a list and whose cdr  points
                      to  the last list cell in that list.  The inter-
                      pretation by the reader of the value returned by
                      an  infix  macro depends on whether the macro is
                      called while the reader is constructing  a  list
                      or  whether it is called at the top level of the
                      reader.  If the macro is called while a list  is
                      being   constructed,  then  the  value  returned
                      should be  a tconc structure.  The car  of  that
                      structure replaces the list of elements that the
                      reader has been collecting.   If  the  macro  is
                      called  at top level, then it will be passed the
                      value nil,  and  the  value  it  returns  should
                      either  be  nil  or  a  tconc structure.  If the
                      macro returns nil, then the value is ignored and
                      the  reader  continues  to  read.   If the macro
                      returns a tconc structure of one  element  (i.e.
                      whose  car  is a list of one element), then that
                      single element is returned as the value of _r_e_a_d_.
                      If  the  macro returns a tconc structure of more
                      than one element, then that list of elements  is
                      returned as the value of read.

              ____________________________________________________

              -> _(_d_e_f_u_n _p_l_u_s_o_p _(_x_)
                       _(_c_o_n_d _(_(_n_u_l_l _x_) _(_t_c_o_n_c _n_i_l _'_\_+_)_)
                             _(_t _(_l_c_o_n_c _n_i_l _(_l_i_s_t _'_p_l_u_s _(_c_a_a_r _x_) _(_r_e_a_d_)_)_)_)_)_)

              plusop
              -> _(_s_e_t_s_y_n_t_a_x _'_\_+ _'_v_i_n_f_i_x_-_m_a_c_r_o _'_p_l_u_s_o_p_)
              t
              -> _'_(_a _+ _b_)
              (plus a b)
              -> _'_+
              |+|
              ->
              ____________________________________________________

                77..66..22..  IInnvvooccaattiioonnss

                        There  are  three  different  circumstances in
                   which you would like a macro function to  be  trig-
                   gered.

                   _A_l_w_a_y_s _-
                        Whenever  the  macro  character  is  seen, the

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                         77--1122

                        macro should be invoked.  This is accomplished
                        by using the character classes _c_m_a_c_r_o, _c_s_p_l_i_c_-
                        _i_n_g_-_m_a_c_r_o, or _c_i_n_f_i_x_-_m_a_c_r_o, and by  using  the
                        _s_e_p_a_r_a_t_o_r   property.    The   syntax  classes
                        vvmmaaccrroo, vvsspplliicciinngg--mmaaccrroo, and vvssiinnggllee--mmaaccrroo are
                        defined this way.

                   _W_h_e_n _f_i_r_s_t _-
                        The  macro  should  only be triggered when the
                        macro character is the first  character  found
                        after  the  scanning  process.  A syntax class
                        for a _w_h_e_n _f_i_r_s_t macro would be defined  using
                        _c_m_a_c_r_o,  _c_s_p_l_i_c_i_n_g_-_m_a_c_r_o,  or _c_i_n_f_i_x_-_m_a_c_r_o and
                        not including the _s_e_p_a_r_a_t_o_r property.

                   _W_h_e_n _u_n_i_q_u_e _-
                        The macro should only be  triggered  when  the
                        macro  character  is  the  only character col-
                        lected in the token collection  phase  of  the
                        reader,  i.e  the macro character is preceeded
                        by zero or more _c_s_e_p_a_r_a_t_o_rs and followed by  a
                        _s_e_p_a_r_a_t_o_r_.   A  syntax class for a _w_h_e_n _u_n_i_q_u_e
                        macro would be  defined  using  _c_s_i_n_g_l_e_-_m_a_c_r_o,
                        _c_s_i_n_g_l_e_-_s_p_l_i_c_i_n_g_-_m_a_c_r_o, or _c_s_i_n_g_l_e_-_i_n_f_i_x_-_m_a_c_r_o
                        and not including the _s_e_p_a_r_a_t_o_r property.  The
                        syntax  classes  so defined are vvssiinnggllee--mmaaccrroo,
                        vvssiinnggllee--sspplliicciinngg--mmaaccrroo,   and   vvssiinnggllee--iinnffiixx--
                        mmaaccrroo.

             77..77..  FFuunnccttiioonnss

          ((sseettssyynnttaaxx 's_symbol 's_synclass ['ls_func]))

               WHERE:   ls_func  is the name of a function or a lambda
                        body.

               RETURNS: t

               SIDE EFFECT: S_symbol should be a  symbol  whose  print
                            name  is  only  one character.  The syntax
                            class  for  that  character  is   set   to
                            s_synclass  in  the current readtable.  If
                            s_synclass is  a  class  that  requires  a
                            character macro, then ls_func must be sup-
                            plied.

               NOTE: The symbolic syntax codes are  new  to  Opus  38.
                     For  compatibility,  s_synclass can be one of the
                     fixnum syntax codes which appeared in older  ver-
                     sions of the FRANZ LISP Manual.  This compatibil-
                     ity is only temporary: existing code  which  uses

                                             Printed: October 16, 1993

          TThhee LLiisspp RReeaaddeerr                                         77--1133

                     the fixnum syntax codes should be converted.

          ((ggeettssyynnttaaxx 's_symbol))

               RETURNS: the  syntax  class  of  the first character of
                        s_symbol's print name.  s_symbol's print  name
                        must be exactly one character long.

               NOTE: This  function  is new to Opus 38.  It supercedes
                     _(_s_t_a_t_u_s _s_y_n_t_a_x_) which no longer exists.

          ((aadddd--ssyynnttaaxx--ccllaassss 's_synclass 'l_properties))

               RETURNS: s_synclass

               SIDE EFFECT: Defines the  syntax  class  s_synclass  to
                            have  properties  l_properties.   The list
                            l_properties should  contain  a  character
                            classes mentioned above.  l_properties may
                            contain  one  of  the  escape  properties:
                            _e_s_c_a_p_e_-_a_l_w_a_y_s,    _e_s_c_a_p_e_-_w_h_e_n_-_u_n_i_q_u_e,   or
                            _e_s_c_a_p_e_-_w_h_e_n_-_f_i_r_s_t.  l_properties may  con-
                            tain the _s_e_p_a_r_a_t_o_r property.  After a syn-
                            tax  class  has  been  defined  with  _a_d_d_-
                            _s_y_n_t_a_x_-_c_l_a_s_s,  the  _s_e_t_s_y_n_t_a_x function can
                            be used to  give  characters  that  syntax
                            class.

              ____________________________________________________

              ; Define a non-separating macro character.
              ; This type of macro character is used in UCI-Lisp, and
              ; it corresponds to a  FIRST MACRO in Interlisp
              -> _(_a_d_d_-_s_y_n_t_a_x_-_c_l_a_s_s _'_v_u_c_i_-_m_a_c_r_o _'_(_c_m_a_c_r_o _e_s_c_a_p_e_-_w_h_e_n_-_f_i_r_s_t_)_)
              vuci-macro
              ->
              ____________________________________________________

                                             Printed: October 16, 1993


robu.custom     <- function(formula, data, studynum,var.eff.size, userweights,
                     modelweights = c("CORR", "HIER"), rho = 0.8,
                     small = TRUE, userdfs = NULL, ...) {

  # Evaluate model weighting scheme.
  modelweights <- match.arg(modelweights)

  if (modelweights == "CORR" && rho > 1 | rho < 0)
    stop ("Rho must be a value between 0 and 1.")

  if (missing(userweights)){
    user_weighting = FALSE
  } else {
    user_weighting = TRUE
  }

  cl                       <- match.call() # Full model call
  mf                       <- match.call(expand.dots = FALSE)
  ml                       <- mf[[2]] # Model formula
  m                        <- match(c("formula", "data", "studynum",
                                      "var.eff.size", "userweights"), names(mf))
  mf                       <- mf[c(1L, m)]
  mf$drop.unused.levels    <- TRUE
  mf[[1L]]                 <- as.name("model.frame")
  mf                       <- eval(mf, parent.frame())

  if(!user_weighting){

    dframe                 <- data.frame(effect.size = mf[,1],
                                         stats::model.matrix(formula, mf),
                                         studynum = mf[["(studynum)"]],
                                         var.eff.size = mf[["(var.eff.size)"]])

    X.full.names           <- names(dframe)[-match(c("effect.size",
                                                     "studynum",
                                                     "var.eff.size"),
                                                   names(dframe))]

  } else { # Begin userweights

    dframe                 <- data.frame(effect.size = mf[,1],
                                         stats::model.matrix(formula, mf),
                                         studynum = mf[["(studynum)"]],
                                         var.eff.size = mf[["(var.eff.size)"]],
                                         userweights = mf[["(userweights)"]])

    X.full.names           <- names(dframe)[-match(c("effect.size",
                                                     "studynum",
                                                     "userweights",
                                                     "var.eff.size"),
                                                   names(dframe))]
  } # End userweights
  study_orig_id            <- dframe$studynum
  dframe$study             <- as.factor(dframe$studynum)
  dframe$study             <- as.numeric(dframe$study)
  dframe                   <- dframe[order(dframe$study),]
  k_temp                   <- as.data.frame(unclass(rle(sort(dframe$study))))
  dframe$k                 <- k_temp[[1]][ match(dframe$study, k_temp[[2]])]
  dframe$avg.var.eff.size  <- stats::ave(dframe$var.eff.size, dframe$study)
  dframe$sd.eff.size       <- sqrt(dframe$var.eff.size)

  switch(modelweights,

         HIER = { # Begin HIER

           dframe$weights <- 1 / dframe$var.eff.size

         }, # End HIER

         CORR = { # Begin CORR

           dframe$weights <- 1 / (dframe$k * dframe$avg.var.eff.size)

         } # End CORR

  )

  X.full           <- dframe[c("study", X.full.names)]

  data.full.names  <- names(dframe)[-match(c("studynum",X.full.names),
                                           names(dframe))]
  data.full        <- dframe[c(data.full.names)]
  k                <- data.full[ !duplicated(data.full$study), ]$k
  k_list           <- as.list(k)
  M                <- nrow(data.full) # Number of units in analysis
  p                <- ncol(X.full) - 2 # Number of (non-intercept) covariates
  N                <- max(data.full$study) # Number of studies
  W                <- as.matrix(by(data.full$weights, data.full$study,
                                   function(x) diag(x, nrow = length(x)),
                                   simplify = FALSE))
  X                <- data.matrix(X.full)
  X                <- lapply(split(X[,2:(p + 2)], X[,1]), matrix, ncol = p + 1)
  y                <- by(data.full$effect.size, data.full$study,
                         function(x) matrix(x))
  J                <- by(rep(1, nrow(X.full)), X.full$study,
                         function(x) matrix(x, nrow = length(x),
                                            ncol = length(x)))
  sigma            <- by(data.full$sd.eff.size, data.full$study,
                         function(x) tcrossprod(x))
  vee              <- by(data.full$var.eff.size, data.full$study,
                         function(x) diag(x, nrow = length(x)))
  SigmV            <- Map(function(sigma, V)
    sigma - V, sigma, vee)
  sumXWX           <- Reduce("+", Map(function(X, W)
    t(X) %*% W %*% X,
    X, W))
  sumXWy           <- Reduce("+", Map(function(X, W, y)
    t(X) %*% W %*% y,
    X, W, y))
  sumXWJWX         <- Reduce("+", Map(function(X, W, J)
    t(X) %*% W %*% J %*% W %*% X,
    X, W, J))

  Matrx_WKXX       <- Reduce("+",
                             Map(function(X, W, k) { t(X) %*% (W / k) %*% X},
                                 X, W, k_list))

  Matrx_wk_XJX_XX <- Reduce("+",
                            Map(function(X, W, J, k) {(W / k)[1,1] * ( t(X) %*% J %*% X - t(X) %*% X) },
                                X, W, J, k_list))

  switch(modelweights,

         HIER = { # Begin HIER

           tr.sumJJ <- Reduce("+", Map(function(J)
             sum(diag(J %*% J)),
             J))
           sumXJX   <- Reduce("+", Map(function(X, J)
             t(X) %*% J %*% X,
             X, J))
           sumXWJJX <- Reduce("+", Map(function(X, W, J)
             t(X) %*% W %*% J %*% J %*% X,
             X, W, J))
           sumXJJWX <- Reduce("+", Map(function(X, W, J)
             t(X) %*% J %*% J %*% W %*% X,
             X, W, J))
           sumXWWX  <- Reduce("+", Map(function(X, W)
             t(X) %*% W %*% W %*% X,
             X, W))
           sumXJWX  <- Reduce("+", Map(function(X, W, J)
             t(X) %*% J %*% W %*% X,
             X , W, J))
           sumXWJX  <- Reduce("+", Map(function(X, W, J)
             t(X) %*% W %*% J %*% X,
             X, W, J))
         } # End HIER

  )

  b              <- solve(sumXWX) %*% sumXWy
  Xreg           <- as.matrix(X.full[-c(1)], dimnames = NULL)
  data.full$pred <- Xreg %*% b
  data.full$e    <- data.full$effect.size - data.full$pred

  if (!user_weighting) {

    switch(modelweights,

           HIER = { # Begin HIER

             # Sigma_aj = tau.sq * J_j + omega.sq * I_j + V_j
             # Qe is sum of squares 1
             # Qe = Sigma(T'WT)-(Sigma(T'WX)(Sigma(X'WX))^-1(Sigma(X'WT)
             # where W = V^(-1) and V = data.full$var.eff.size
             # Also, Qe = (y-xb)' W (y-xb)
             sumV <- sum(data.full$var.eff.size)
             W    <- diag(1 / data.full$var.eff.size)
             sumW <- sum(W)
             Qe   <- t(data.full$e) %*% W %*% data.full$e

             # Qa is sum of squares 2
             # Qa = sum(T-XB.hat)'J(T-XB.hat)
             # where B.hat = (X'WX)^-1(X'WT)
             # Also, Qa = (y-xb)'A (y-xb), A=diag(J)
             e      <- by(data.full$e, data.full$study, function(x) matrix(x))
             sumEJE <- Reduce("+", Map(function(e, J) t(e) %*% J %*% e, e, J))
             Qa     <- sumEJE

             # MoM estimators for tau.sq and omega.sq can be written as
             # omega.sq.h = A2(Qa-C1)-A1(Qe-C2) / B1A2-B2A1
             # tau.sq.h = Qe-C2/A2 - omega.sq.h(B2/A2) where

             # Vi = (t(X)WX)^-1
             V.i    <- solve(sumXWX)

             # A1 = Sigma(kj^2) - tr(V*Sigma(kj*t(Xj)*Jj*Wj*Xj)) -
             #                    tr(V*Sigma(kj*t(Xj)*Jj*Wj*Xj)) +
             #                    tr(V*[Sigma(t(Xj)*Jj*Xj)]*V*Sigma(t(Xj)*Wj*Jj*Wj*Xj))
             # B1 = Sigma(kj)   - tr(V Sigma(t(Xj)*Jj*Wj*Xj)) -
             #                    tr(V Sigma(t(Xj)*Wj*Jj*Xj)) +
             #                    tr(V*[Sigma(t(Xj)*Jj*Xj)]*V*Sigma(t(Xj)*Wj^2*Xj))
             # C1 = tr(W^-1)    - tr(V*Sigma(t(X)*Jj*Xj))

             A1    <- tr.sumJJ  - sum(diag(V.i %*% sumXJJWX)) -
               sum(diag(V.i %*% sumXWJJX)) +
               sum(diag(V.i %*% sumXJX %*% V.i %*% sumXWJWX))

             B1    <- length(data.full$study) -
               sum(diag(V.i %*% sumXWJX)) -
               sum(diag(V.i %*% sumXJWX)) +
               sum(diag(V.i %*% sumXJX%*%V.i %*% sumXWWX))
             C1    <- sumV - sum(diag(V.i %*% sumXJX))

             # A2 = tr(W) - tr(V*Sigma(t(X)*Wj*Jj*Wj*Xj))
             # B2 = tr(W) - tr(V*Sigma(t(X)*Wj^2*Xj))
             # C2 = Sigma(kj-p)

             A2   <- sumW - sum(diag(V.i %*% sumXWJWX))
             B2   <- sumW - sum(diag(V.i %*% sumXWWX))
             C2   <- length(data.full$study) - (p + 1)

             # MoM estimator for omega.sq.h = A2(Qa-C1)-A1(Qe-C2) / B1A2-B2A1
             # Estimate of between-studies-wthin-cluster variance component
             omega.sq1  <- ((Qa - C1) * A2 - (Qe - C2) * A1) / (B1 * A2 - B2 * A1)
             omega.sq   <- ifelse(omega.sq1 < 0, 0, omega.sq1)

             # MoM estimators for tau.sq: Qe-C2/A2 - omega.sq.h(B2/A2)
             # Estimate of between-clusters variance component
             tau.sq1  <- ((Qe - C2) / A2) - omega.sq  * (B2 / A2)
             tau.sq   <- ifelse(tau.sq1 < 0, 0, tau.sq1)

             # Approximate inverse variance weights
             data.full$r.weights <- (1 / (as.vector(data.full$var.eff.size) +
                                            as.vector(tau.sq) +
                                            as.vector(omega.sq)))

             # Model info list for hierarchical effects
             mod_info            <- list(omega.sq = omega.sq, tau.sq = tau.sq)

           }, # End HIER

           CORR = { # Begin CORR

             W       <- diag (data.full$weights)
             sumW    <- sum(data.full$weights) # Sum (k.j*w.j)
             Qe      <- t(data.full$e) %*% W %*% data.full$e

             # The following components (denom, termA, termB, term1, term2)
             # are used in the calculation of the estimate of the residual
             # variance component tau.sq.hat.
             # Note: The effect of correlation on the estimates occurs entirely
             # through the rho*term2 component.

             denom   <- sumW - sum(diag(solve(sumXWX) %*% sumXWJWX))
             termA   <- sum(diag(solve(sumXWX) %*% Matrx_WKXX)) #ZH_edit
             termB   <- sum(diag(solve(sumXWX) %*% Matrx_wk_XJX_XX ))#ZH_edit
             term1   <- (Qe - N + termA) / denom
             term2   <- termB / denom
             tau.sq1 <- term1 + rho * term2
             tau.sq  <- ifelse(tau.sq1 < 0, 0, tau.sq1)
             df      <- N - termA - rho * (termB)
             I.2.1   <- ((Qe - df) / Qe) * 100
             I.2     <- ifelse(I.2.1 < 0, 0, I.2.1)

             # Approximate inverse variance weights
             data.full$r.weights <- 1 / (as.vector(data.full$k) *
                                           (as.vector(data.full$avg.var.eff.size) +
                                              as.vector(tau.sq)))

             # Model info list for correlated effects
             mod_info            <- list(rho = rho, I.2 = I.2, tau.sq = tau.sq,
                                         term1 = term1, term2 = term2)

           } # End CORR

    )

  } else { # Begin userweights

    data.full$r.weights <- data.full$userweights

    # Model info list for userweights
    mod_info            <- list(k = k, N = N, p = p, M = M)

  } # End userweights

  W.r.big          <- diag(data.full$r.weights)  # W
  W.r              <- by(data.full$r.weights, data.full$study, # Wj
                         function(x) diag(x, nrow = length(x)))
  sumXWX.r         <- Reduce("+", Map(function(X, W)
    t(X) %*% W %*% X,
    X, W.r))
  sumXWy.r         <- Reduce("+", Map(function(X, W, y)
    t(X) %*% W %*% y,
    X, W.r, y))
  b.r              <- solve(sumXWX.r) %*% sumXWy.r
  data.full$pred.r <- Xreg %*% b.r
  data.full$e.r    <- cbind(data.full$effect.size) - data.full$pred.r
  data.full$e.r    <- as.numeric(data.full$e.r)
  sigma.hat.r      <- by(data.full$e.r, data.full$study,
                         function(x) tcrossprod(x))

  if (!small) { # Begin small = FALSE

    sumXWeeWX.r  <- Reduce("+", Map(function(X, W, V)
      t(X) %*% W %*% V %*% W %*% X,
      X, W.r, sigma.hat.r))

    VR.r         <- solve(sumXWX.r) %*% sumXWeeWX.r %*% solve(sumXWX.r)
    SE           <- sqrt(diag(VR.r)) * sqrt(N / (N - (p + 1)))
    t            <- b.r / SE
    if (is.null(userdfs))
      dfs <- N - (p + 1)
    else
      dfs <- userdfs
    prob         <- 2 * (1 - stats::pt(abs(t), dfs))
    CI.L         <- b.r - stats::qt(.975, dfs) * SE
    CI.U         <- b.r + stats::qt(.975, dfs) * SE

  } else { # Begin small = TRUE

    Q             <- solve(sumXWX.r) # Q = (X'WX)^(-1)
    Q.list        <- rep(list(Q), N)
    H             <- Xreg %*% Q %*% t(Xreg) %*% W.r.big # H = X * Q * X' * W
    ImH           <- diag(c(1), dim(Xreg)[1], dim(Xreg)[1]) - H
    data.full$ImH <- cbind(ImH)

    ImHj <- lapply(split(x = ImH,f =  as.factor(data.full$study)),
                   function(x){matrix(x, ncol =M)})
    #ImHj          <- by(data.full$ImH, data.full$study,
    #                    function(x) as.matrix(x))

    diag_one      <- by(rep(1, M), X.full$study,
                        function(x) diag(x, nrow = length(x)))

    ImHii         <- Map(function(X, Q, W, D)
      D - X %*% Q %*% t(X) %*% W,
      X, Q.list, W.r, diag_one)

    if (!user_weighting){

      Working_Matrx_E <- diag(1/data.full$r.weights)  #1/W
      Working_Matrx_E_j <- by(data.full$r.weights, data.full$study, # Wj
                              function(x) diag(1/x, nrow = length(x))) #1/W_j

      switch(modelweights,
             HIER = {
               # Inside Matrix = E_j^0.5 * ImH_j *E * t(ImH_j) * E_j^0.5
               # In this case, the formula can be simplified to
               # Inside Matrix = E_j^0.5 * ImH_jj * E_j^1.5
               InsideMatrx_list <-   Map(
                 function (W_E_j, ImH_jj) {
                   sqrt(W_E_j) %*% ImH_jj %*% (W_E_j^1.5)
                 },
                 Working_Matrx_E_j, ImHii)

               eigenres_list <- lapply(InsideMatrx_list, function(x) eigen(x))
               eigenval_list <- lapply(eigenres_list, function(x) x$values)
               eigenvec_list <- lapply(eigenres_list, function(x) x$vectors)

               A.MBB  <- Map(function (eigenvec, eigenval, k, W_E_j) {
                 eigenval_InvSqrt <- ifelse(eigenval< 10^-10, 0, 1/sqrt(eigenval)) # Pseudo_Inverse
                 sqrt(W_E_j) %*% eigenvec %*% diag(eigenval_InvSqrt, k, k) %*% t(eigenvec) %*%sqrt(W_E_j) # Pseudo_Inverse
               },
               eigenvec_list,
               eigenval_list,
               k_list,
               Working_Matrx_E_j)

             },

             CORR = {
               # In this case, the formula can be simplified to
               # A_MBB =  ImH_jj ^ (-0.5)

               eigenres_list <- lapply(ImHii, function(x) eigen(x))
               eigenval_list <- lapply(eigenres_list, function(x) x$values)
               eigenvec_list <- lapply(eigenres_list, function(x) x$vectors)

               A.MBB  <- Map(function (eigenvec, eigenval, k, W_E_j) {
                 eigenval_InvSqrt <- ifelse(eigenval< 10^-10, 0, 1/sqrt(eigenval)) # Pseudo_Inverse
                 eigenvec %*% diag(eigenval_InvSqrt, k, k) %*% t(eigenvec) # Pseudo_Inverse
               },
               eigenvec_list,
               eigenval_list,
               k_list,
               Working_Matrx_E_j)
             })

    } else { # Begin userweights

      V.big        <- diag(c(1), dim(Xreg)[1], dim(Xreg)[1]) %*%
        diag(data.full$avg.var.eff.size)
      v.j          <- by(data.full$avg.var.eff.size, data.full$study,
                         function(x) diag(x, nrow = length(x)))
      v.j.sqrt_list     <- lapply(v.j, function (x) sqrt(x))

      Working_Matrx_E_j <- v.j
      Working_Matrx_E <- V.big

      InsideMatrx_list <-   Map(
        function (ImH_j) {
          ImH_j %*% Working_Matrx_E %*% t(ImH_j)
        },
        ImHj)

      eigenres_list <- lapply(InsideMatrx_list, function(x) eigen(x))
      eigenval_list <- lapply(eigenres_list, function(x) x$values)
      eigenvec_list <- lapply(eigenres_list, function(x) x$vectors)

      A.MBB  <- Map(function (eigenvec, eigenval, k, v.j.sqrt) {
        eigenval_InvSqrt <- ifelse(eigenval< 10^-10, 0, 1/sqrt(eigenval)) # Pseudo_Inverse
        v.j.sqrt %*% eigenvec %*% diag(eigenval_InvSqrt, k, k) %*% t(eigenvec)  # Pseudo_Inverse
      },
      eigenvec_list,
      eigenval_list,
      k_list,
      v.j.sqrt_list)

    } # End userweights

    sumXWA.MBBeeA.MBBWX.r <- Map(function(X,W,A,S)
      t(X) %*% W %*% A %*% S %*% A %*% W %*%X,
      X, W.r, A.MBB, sigma.hat.r)

    sumXWA.MBBeeA.MBBWX.r <- Reduce("+", sumXWA.MBBeeA.MBBWX.r)
    giTemp                <- Map(function(I, A, W, X, Q)
      t(I) %*% A %*% W %*% X %*% Q,
      ImHj, A.MBB, W.r, X, Q.list)

    giTemp <- do.call(rbind,giTemp)
    gi_matrix <- lapply(X = 1:(p+1), FUN = function(i){ matrix(giTemp[,i], nrow = M)  })

    if (!user_weighting) {
      W.mat <- matrix(rep(1/sqrt(data.full$r.weights),times = N),nrow = M)
      B_matrix_half <- lapply(X = gi_matrix, FUN = function(gi_mat){ W.mat * gi_mat})
    }else{

      B_matrix_half <- gi_matrix
      # B_matrix_half <- lapply(X = gi_matrix, FUN = function(gi_mat){ solve(sqrt(V.big)) %*% gi_mat})
    }

    B_mat <- lapply(X = B_matrix_half, FUN = tcrossprod)

    B_trace_square <- sapply(X = B_mat, FUN = function(B){ (sum(diag(B)))^2})

    B_square_trace <- sapply(X = B_mat, FUN = function(B){sum(B * B)})

    if (is.null(userdfs))
      dfs <- B_trace_square/B_square_trace
    else
      dfs <- userdfs

    VR.MBB1 <- solve(sumXWX.r) %*% sumXWA.MBBeeA.MBBWX.r %*% solve(sumXWX.r)
    VR.r    <- VR.MBB1
    SE      <- sqrt(diag(VR.r))
    t       <- b.r / SE
    prob    <- 2 * (1 - stats::pt(abs(t), df = dfs))
    CI.L    <- b.r - stats::qt(.975, dfs) * SE
    CI.U    <- b.r + stats::qt(.975, dfs) * SE

  } # End small = TRUE

  reg_table           <- data.frame(cbind(b.r, SE, t, dfs, prob, CI.L, CI.U))
  #names(X.full)[2]    <- "intercept"
  labels              <- c(colnames(X.full[2:length(X.full)]))
  sig                 <- ifelse(prob < .01, "***",
                                ifelse(prob > .01 & prob < .05, "**",
                                       ifelse(prob > .05 & prob < .10, "*", "")))
  reg_table           <- cbind(labels, reg_table, sig)
  colnames(reg_table) <- c("labels", "b.r", "SE", "t", "dfs", "prob", "CI.L",
                           "CI.U", "sig")

  if (!small) { # Begin small = FALSE

    mod_label_sm   <- ""
    mod_notice     <- ""

  } else { # Begin small = TRUE

    mod_label_sm  <- "with Small-Sample Corrections"
    mod_notice    <- "Note: If df < 4, do not trust the results"

  } # End small = TRUE

  if (!user_weighting) {

    switch(modelweights,

           HIER = { # Begin HIER

             mod_label <- c("RVE: Hierarchical Effects Model", mod_label_sm)

           }, # End HIER

           CORR = { # Begin CORR

             mod_label <- c("RVE: Correlated Effects Model", mod_label_sm)

           } # End CORR

    )

  } else { # Begin userweights

    mod_label <- c("RVE: User Specified Weights", mod_label_sm)

  } # End userweights

  res <- list(data.full = data.full, X.full = X.full, reg_table = reg_table,
              mod_label = mod_label, mod_notice = mod_notice, modelweights =
                modelweights, mod_info = mod_info, user_weighting =
                user_weighting, ml = ml, cl = cl, N = N, M = M, k = k,
              k_list = k_list, p = p, X = X, y = y, Xreg = Xreg, b.r = b.r,
              VR.r = VR.r, dfs = dfs, small = small, data = data, labels =
                labels, study_orig_id = study_orig_id)

  class(res) <- "robu"
  res
}