#' Dyad Ratios Algorithm
#'
#' Estimates the Dyad Ratios Algorithm for constructing latent time series from
#' survey-research marginals.
#'
#' @name extract
#' @aliases extract
#' @param varname String giving the name of the input series to be smoothed.
#'   This should identify similar or comparable values in the series. Values in
#'   the series that have the same \code{varname} will be assumed to come from
#'   the same source.
#' @param date ISO numeric representation of the date the survey was in the
#'   field (usually the start, end, or median date).
#' @param index Numeric value of the series. It might be a percent or proportion
#'   responding in a single category (e.g., the approve response in presidential
#'   approval) or some multi-response summary. For ease of interpretation,
#'   polarity should be the same for all items.
#' @param ncases Number of cases (e.g., sample size) of the survey. This provides
#'   differential weighting for the values. Setting this to \code{NULL} or
#'   leaving it blank will weight each value equally.
#' @param unit Aggregation period—one of \sQuote{D} (daily), \sQuote{M}
#'   (monthly), \sQuote{Q} (quarterly), \sQuote{A} (annual), or \sQuote{O}
#'   (multi-year aggregation).
#' @param mult Number of years, only used if \code{unit} is \sQuote{O}.
#' @param begindt Beginning date of the analysis. Defaults to earliest date in
#'   the dataset. Should be specified with \code{lubridate::ymd()}.
#' @param enddt Ending date for the analysis. Defaults to the latest date in the
#'   data.
#' @param npass Not yet implemented.
#' @param smoothing Logical. Specifies whether exponential smoothing is applied
#'   to the intermediate estimates during the iterative solution process.
#'   Defaults to \code{TRUE}.
#' @param endmonth Ending month of the analysis.
#'
#' @details In previous versions of the algorithm, especially in its original incarnation as `Wcalc.exe`, getting the dates right was really important.  They needed to be in precisely the right format and the
#' data needed to be ordered by date.  In this version of the `extract()` function, any R date class is fine whether it is a `Date` class or `POSIX*` class.  The function uses `is.Date` from the 
#' `lubridate` package to check if it is a `Date` class and `as.Date()` from R's `base` package to coerce it to a `Date` class if it is not.  Further, the series are ordered by date in the function 
#' as a matter of course, so it is not necessary that they be in ascending ordered of date in the input data. 
#'
#' @return A list with components:
#' \itemize{
#'   \item \code{call}: The initial call to `extract()`. 
#'   \item \code{T}: Number of aggregation periods.
#'   \item \code{nvar}: Number of series used in the analysis.
#'   \item \code{unit}: The aggregation period.
#'   \item \code{dimensions}: Number of dimensions estimated (1 or 2).
#'   \item \code{period}: List of aggregation periods.
#'   \item \code{varname}: List in order of the variables used in the analysis.
#'   \item \code{N}: Number of non-missing observations for each series.
#'   \item \code{wtdmean}: The weighted mean of the input variables. 
#'   \item \code{wtstd}: The weighted standard deviation of the input series. 
#'   \item \code{means}: Item descriptive information.
#'   \item \code{std.deviations}: Item descriptive information.
#'   \item \code{setup1}: Basic information about the options and iterative solution for the first dimension.
#'   \item \code{setup2}: Basic information about the options and iterative solution for the second dimension, if applicable.
#'   \item \code{loadings1}: Item–scale correlations from the first dimension of the final solution.
#'     Their square is the validity estimate used in weighting.
#'   \item \code{loadings2}: Item–scale correlations from the second dimension of the final solution, if applicable.
#'   \item \code{latent1}: Estimated time series for first dimension.
#'   \item \code{latent2}: Estimated time series for second dimension, if applicable.
#'   \item \code{hist}: Data frame with iteration history, including convergence statistics.
#'   \item \code{totalvar}: Total variance in the data that could be explained by the estimated dimensions.
#'   \item \code{var_exp}: Data frame with variance explained and proportion of variance explained for each dimension.
#'   \item \code{dropped}: Data frame listing any series that were dropped from the analysis due to insufficient data.
#'   \item \code{smoothing}: Logical indicating whether smoothing was applied during the iterative solution process.
#'   \item \code{ms_list}: List of means and variances for standardizing the input series for the bootstrap. 
#' }
#'
#' @references
#' Stimson, J. A. (2018).
#' \sQuote{The Dyad Ratios Algorithm for Estimating Latent Public Opinion:
#' Estimation, Testing, and Comparison to Other Approaches},
#' \emph{Bulletin of Sociological Methodology/Bulletin de Méthodologie
#' Sociologique}, 137–138(1), 201–218. \doi{10.1177/0759106318761614}
#'
#' @importFrom stats cor lm optim sd var
#' @importFrom graphics legend lines par plot 
#' @importFrom lubridate ymd year month day quarter is.Date
#' 
#' @usage NULL
#' @export
#'
#' @examples
#' data(jennings)
#' dr_out <- extract(varname = jennings$variable, 
#'                   date = jennings$date, 
#'                   index = jennings$value, 
#'                   ncases = jennings$n, 
#'                   begindt = min(jennings$date), 
#'                   enddt = max(jennings$date), 
#'                   npass=1)
#' summary(dr_out)
#' 
extract <- function(varname,date,index,ncases=NULL,unit="A",mult=1,begindt=NA,enddt=NA,npass=1,smoothing=TRUE,endmonth=12) {
  if(!is.Date(date))date <- as.Date(date)
  tmp <- data.frame(varname = varname, date = date, index = index, ncases = ncases)
  sp_tmp <- split(tmp, tmp$varname)
  for(i in seq_along(sp_tmp)) {
    sp_tmp[[i]] <- sp_tmp[[i]][order(sp_tmp[[i]]$date), ]
  }
  tmp <- do.call(rbind, sp_tmp)
  varname <- tmp$varname
  index <- tmp$index
  date <- tmp$date
  ncases <- tmp$ncases
  formula<-match.call(extract)
  nrecords<- length(varname)
  if (is.null(ncases)) ncases<- rep(0,nrecords)
  moddate <- date #create temporary date vector, leaving original unmodified
  if ((unit=="A" || unit=="O") && endmonth<12) {
    for (i in 1:nrecords) { #first loop through raw data file
      month<- month(moddate[i])
      year<- year(moddate[i])
      if (month>endmonth) moddate[i]<- ymd(paste(year, "01", "01", sep="-")) #modified date become 1/1 of next year
    } #end loop through data
  } # end if

  if (is.na(begindt)) minper<-month(min(moddate)) else minper<-month(begindt)
  if (is.na(begindt)) miny<-year(min(moddate)) else miny<-year(begindt)
  if (is.na(begindt)) minday<-day(min(moddate)) else minday<-day(begindt)
  if (is.na(enddt)) maxper<-month(max(moddate)) else maxper<-month(enddt)
  if (is.na(enddt)) maxy<-year(max(moddate)) else maxy<-year(enddt)
  if (is.na(enddt)) maxday<-day(max(moddate)) else maxday<-day(enddt)
  mindate <- lubridate::ymd(paste(miny, minper, minday, sep="-"))
  maxdate <- lubridate::ymd(paste(maxy, maxper, maxday, sep="-"))

  w <- which(moddate >= mindate & moddate <=maxdate)
  if(length(w) == 0){
    stop("No surveys within date range. \n")
  }
  varname <- varname[w]
  index <- index[w]
  if(!is.null(ncases)){
    ncases <- ncases[w]
  }
  moddate <- moddate[w]
  date <- date[w]
  
  if (unit=="Q") {
    minper<- as.integer((minper-1)/3)+1
    maxper<- as.integer((maxper-1)/3)+1
  }
  # mindate<- ISOdate(miny,minper,minday,0,0,0,tz="GMT")
  # maxdate<- ISOdate(maxy, maxper, maxday,0,0,0,tz="GMT") #86400=24*60*60

  
  
  #SETCONS:
  latent<- numeric(1)
  aggratio<- 0
  fb<- 1 #initialize
  auto<- "start"  #meaningless value
  alpha<- 1
  alpha1<- 1
  pass<- 1
  holdtola<- 0.001
  tola<- holdtola
  iter<- 0
  lastconv<- 99999
  wtmean<- 0 #for it=1
  wtstd<- 1
  fract<- 1
  iter_hist <- NULL
  dropped <- NULL
  if (unit=="A") {
    nperiods<- maxy-miny+1
    aggratio<- 1
    months<- 12
  }
  if (unit=="O") {
    years<- mult
    months<- years*12
    aggratio<- 2
    odd<- (maxy-miny+1) %% mult  #mod
    nperiods=as.integer((maxy-miny)/mult) + odd
  }
  if (unit=="M") {
    fract<- 100
    nperiods<- (maxy-miny)*12
    nperiods<- nperiods-12 + (12-minper+1) + maxper
    aggratio<- 1/12
    months<- 1
  }
  if (unit=="Q") {
    aggratio<- 1/4
    months<- 3
    nperiods<- as.integer((maxy-miny)/aggratio)
    nperiods<- nperiods-4 + (4-minper+1) + maxper
    fract<- 10
  }
  if (unit=="D") {
    months=1
    nperiods<- (as.integer(maxdate)-as.integer(mindate)) + 1 
  }

  arinv<- 1/aggratio
  aggratio<- months/12
  nrecords<- length(index)

#HERE WE SET UP FUNDAMENTAL DIMENSIONS AND DECLARE VECTORS
  if (fb != 2)  mood<- array(dim=c(3,nperiods))
  vfac<- factor(varname) #make a factor vector
  vlev<- levels(vfac)    #find unique categories
  nvar<- length(vlev)    #how many are there?, includes unusable series
  valid <- numeric(nvar)
  csign <- numeric(nvar)
  vl <- character(nvar)
  r<- numeric(nvar)
  oldr<- rep(1,nvar) # r=1 for all v initially

  issue<- array(dim=c(nperiods,nvar))
  count<- numeric(nperiods)
  vl<- numeric(nvar)
  period<- numeric(nperiods)
  converge<- 0
  evalue<- 0
  evalue1 <- 0
  evalue2 <- NULL
  # create numeric variable period, eg, yyyy.0m 
  if (unit=="D") {
    period<-seq(1:nperiods) 
    } else {
  if (months >= 12) {
    for (l in 1:nperiods) { 
      p <- (l - 1) * aggratio
      period[l] <- miny + p
      } #next l
   } else {
     y <- 0
     i <- 0
     my <- miny
     if (minper == 1)  my <- my - 1
     for (l in 1:nperiods) { 
       i<- 1 + ((l-1) %% arinv)
       mq <- minper + i - 1
       mq<- 1 + ((mq-1) %% arinv) 
       if (mq == 1)  y <- y + 1 #first month or quarter, increment year
       period[l] <- my + y + mq / fract
     } # end for
   } #end else
  } # end if


  agglist<- aggregate(varname,moddate,index,ncases,mindate,maxdate,nperiods,nvar,aggratio,unit,miny,minper) # call aggregate to produce issue matrix
  vl<- agglist$lab #extract two elements of the list from aggregate call
  issue<- agglist$iss
  rm(agglist) #don't need this anymore

  #NOW REDUCE ISSUE MATRIX TO ELIMINATE UNUSABLE SERIES (WN<2)
  ndrop<- 0
  nissue<- numeric(nperiods)
  std<- numeric(nperiods)
  for (v in 1:nvar) {
    std[v]<- 0 #default
    nissue[v]<- sum(!is.na(issue[,v])) #criterion is 2 cases for npass=1 or 3 for npass=2
    if (nissue[v]>npass) std[v]<- sqrt(var(issue[,v],na.rm=TRUE)) #this is just a test for variance >0
    if (std[v]<.001) {  #case dropped if std uncomputable (NA) or actually zero (constant)
      ndrop<- ndrop+1
      dropped <- rbind(dropped, data.frame(Dropped = vl[v], N_remain = nissue[v]))
    }
    }
  nvarold<- nvar
  nvar<- nvar-ndrop
  pointer<- 1
  found<- FALSE
  
  for (v in 1:nvar) { #now reduced nvar
    while (found==FALSE && pointer<=nvarold) { #find first valid column and push down
      if (std[pointer]>.001) { #good case, transfer
         issue[,v]<- issue[,pointer]
         vl[v]<- vl[pointer]
         pointer<- pointer+1
         found<- TRUE
      } else {
        pointer<- pointer+1 #bad case, increment pointer
      } #end if
    } #end while
    found<- FALSE
  } #for
  length(vl)<- nvar #reduce  
  length(issue)<- nperiods*nvar  #chop off unused columns
  attr(issue,"dim")<- c(nperiods,nvar)
  N<- numeric(nvar)

#export<<-list(nperiods,nvar,issue)

  ms_list <- vector(mode = "list", length=npass)
  for (pass in 1:npass) { #newpass: RESTART FOR SECOND DIMENSION CASE
    if (pass == 2) { #reset iteration control parameters
      iter <- 0
      tola = holdtola
      lastconv <- 99999
      converge<- lastconv
      conv<- converge
    } else {
      av<- numeric(nvar)
      std<- numeric(nvar)
#      ngood<- 0
      for (v in 1:nvar) { #compute av and std by issue nvar now reduced to good cases
        wn<- as.integer(nperiods-sum(is.na(issue[,v])))
        av[v] <- mean(issue[,v],na.rm=TRUE)
        std[v]<- sqrt(var(issue[,v],na.rm=TRUE) * ((wn - 1)/wn)) #convert to population standard deviation
        issue[,v]<- 100 + 10 * (issue[,v] - av[v])/std[v]  #standardize
#        ngood<- ngood+1
      }#end for
    ms_list[[pass]] <- list(av=av, std=std)
    }
    #READY FOR ESTIMATION, SET UP AND PRINT OPTIONS INFO     
    out<- as.character(10) #initial length only
    setup <- list(start = miny, end = maxy, nperiods = nperiods, used_series = nvar, unused_series = ndrop, smoothiing=smoothing)
    if(!is.null(minper)){
      setup$minper <- minper
      setup$maxper <- maxper
    }
    for (p in 1:nperiods) {
      count[p]<- sum(!is.na(issue[p,]))
    }
    valid <- rep(1, times = nvar)
    csign <- rep(1, times = nvar)
    auto <- "y"              #iterative estimation on by default
    quit <- 0                #false implies go ahead and estimate

    while (iter == 0 || converge > tola) {   #MASTER CONTROL LOOP WHICH ITERATES UNTIL SOLUTION REACHED

      for (fb in 1:2) { #    MASTER fb LOOP       fb=1 is forward, 2 backward 
        dominate.out<- dominate(fb,issue,nperiods,nvar,mood,valid,smoothing,alpha, csign)  #master estimation routine
        alpha1<- dominate.out$alpha1
        alpha<- dominate.out$alpha
        mood[fb,]<- dominate.out$latent
        } #next fb

    fb <- 3 #average mood from here on
    for (p in 1:nperiods) { #    AVERAGE
      mood[fb, p] <- (mood[1, p] + mood[2, p]) / 2
    } #next p
    moodmean<-mean(mood[3,])
    sdmood<-sd(mood[3,])
    for (p in 1:nperiods) {  #PLACEMENT OF THIS LOOP MAY NOT BE RIGHT
      mood[fb,p] <- ((mood[fb,p] - moodmean) * wtstd / sdmood) + wtmean
    } #end for

    iter <- iter + 1 
    if (auto == "y") r<- iscorr(issue,mood) else auto <- "y"   #recompute correlations

    wtmean<- 0
    wtstd<- 0
    vsum<- 0
    goodvar<- 0
    converge<- 0 #start off default
    evalue<- 0
    totalvar<- 0

    for (v in 1:nvar) {
      wn<- nperiods-sum(is.na(issue[,v]))
      if (!is.na(sign(r[v]))) csign[v]<- sign(r[v])
      #if (!is.na(sign(r[v]))) csign[v]<<- sign(r[v])
      wn<- nperiods-sum(is.na(issue[,v]))
      if (wn>1) { #sum over variables actually used
        vratio <- wn / nperiods
        evalue <- evalue + vratio * r[v]^2
        totalvar <- totalvar + vratio
      } #end if
      evalue1 <- evalue
      totalvar1 <- totalvar
      #convergence tests
      if (wn > 3) {
       conv <- abs(r[v] - oldr[v])      #conv is convergence test for item=v
       conv <- conv * (wn / nperiods)                #weight criterion by number of available periods
       if (conv > converge)  converge <- conv        #converge is the global max of conv
      } #end if
      if (!is.na(r[v])) oldr[v] <- r[v]
      if (!is.na(r[v])) valid[v] <- r[v]^2
      if (!is.na(av[v])) wtmean <- wtmean + av[v] * valid[v]
      if (!is.na(std[v])) wtstd <- wtstd + std[v] * valid[v]
      if (!is.na(r[v])) vsum <- vsum + valid[v]
    } #end v loop

    if (vsum > 0)  wtmean <- wtmean / vsum
    if (vsum > 0)  wtstd <- wtstd / vsum
    if (pass == 1) {
      mean1 <- wtmean
      std1 <- wtstd
      e1=evalue
    } else {
      wtmean <- mean1
      wtstd <- std1 #*unexp
    } #end if
    fbcorr <- cor(mood[1,],mood[2,]) #fnfrontback 
    if (quit != 1) {
      cv<- format(round(converge,4),nsmall=4) 
      itfmt<-format(round(iter),justify="right",length=4)
      iter_hist <- rbind(iter_hist, data.frame(Dimension = paste0("Dimension ", pass), Iter = itfmt, Convergence = cv, Criterion = tola, 
                                                Reliability = fbcorr, Alphaf = alpha1, Alphab = alpha))
      }
    if (converge > lastconv)  tola <- tola * 2
    lastconv <- converge

    auto = "y"  #skip corr on iter=1, set auto on

    if (iter >= 50) break #get out of while loop
    } #END MASTER WHILE ITERATION CONTROL LOOP

    if (auto == "y" && converge<tola) { #IF WE REACH THIS CODE WE HAVE A FINAL SOLUTION TO BE REPORTED
    if (pass == 1) out1<- out #hold output for 2 dimensional solution
    auto <- "Q"
    quit <- 1                #flag solution reached, last time through
    r<- iscorr(issue,mood)   #final iteration correlations
    if (pass == 1) r1<- r #hold correlations for 2 dimensional solution

    if (pass > 1) {
      unexp <- totalvar 
      totalvar <- unexp * totalvar
      evalue <- evalue * unexp
    } #    end if

    if (pass == 1) {
      expprop <- evalue / totalvar
      tot1 <- totalvar
      tot_var <- tot1
      expprop1 <- expprop
    } else {
      erel <- evalue / totalvar          #% exp relative
      totalvar <- (1 - expprop) * tot1   #true var=original var discounted by %exp
      evalue <- erel * totalvar          #rescale to retain %exp relationship
      expprop <- evalue / tot1           #now reduce eral to expprop
      evalue2 <- evalue
      expprop2 <- expprop
    } #    end if

    for (v in 1:nvar) {
      N[v]<- sum(!is.na(issue[,v]))
      }
    var.out<- list(varname=vl,loadings=r,means=av,std.deviations=std)
    if (pass !=  2 && npass>1) {
      for (v in 1:nvar) { 
        valid[v] <- 0               #reset all, regmoodissue will set good=1
        if (csign[v] != 0)  issue[,v]<- residmi(issue,v,mood)   #regmoodissue()
       } #v loop
    }  # if
    #begin prn output routine # mood[fb,] is now our estimate,    WHAT ABOUT A SECOND DIMENSION
    
    var_exp <- data.frame(Dimension =  "Dimension 1", 
               Variance = evalue1, 
               Proportion = expprop1)
    if(!is.null(evalue2)){
      var_exp <- rbind(var_exp, 
                       data.frame(Dimension = "Dimension 2", 
                                  Variance = evalue2, 
                                  Proportion = expprop2))
    }
    
    latent<- mood[fb,] #vector holds values for output
    if (pass == 1) latent1<- latent #hold first dimension
    #for Zelig output
    if (npass==1) {
      extract.out<- list(call=formula,
                         T=nperiods,
                         nvar=nvar,
                         unit=unit,
                         dimensions=npass,
                         period=period,
                         varname=vl,
                         N=N,
                         wtdmean=wtmean,
                         wtdstd=wtstd,
                         means=av,
                         std.deviations=std,
                         setup1=out1,
                         loadings1=r1,
                         latent1=latent1, 
                         hist = iter_hist, 
                         totalvar = totalvar1, 
                         var_exp = var_exp, 
                         dropped=dropped, 
                         smoothing = smoothing, 
                         ms_list = ms_list)
    } else {
    extract.out<- list(call=formula,
                       T=nperiods,
                       nvar=nvar,
                       unit=unit,
                       dimensions=npass,
                       period=period,
                       varname=vl,
                       N=N,
                       wtdmean=wtmean,
                       wtdstd=wtstd,
                       means=av,
                       std.deviations=std,
                       setup1=out1,
                       loadings1=r1,
                       latent1=latent1,
                       setup2=out,
                       loadings2=r,
                       latent2=latent, 
                       hist = iter_hist,
                       totalvar = totalvar1, 
                       var_exp = var_exp, 
                       dropped=dropped, 
                       smoothing = smoothing, 
                       ms_list = ms_list)
    }
    } #end if auto="y" 
  } #end of for pass=1,2 loop 

  # par(col=1) #reset on termination
  class(extract.out)<- "extract"
  return(extract.out)
  }

#' Extract for bootstrap includes arguments for means and standard deviations for standardizing
#' @noRd
extract_bs <- function(varname,date,index,ncases=NULL,unit="A",mult=1,begindt=NA,enddt=NA,npass=1,smoothing=TRUE,endmonth=12, wm, ws) {
  if(!is.Date(date))date <- as.Date(date)
  tmp <- data.frame(varname = varname, date = date, index = index, ncases = ncases)
  sp_tmp <- split(tmp, tmp$varname)
  for(i in seq_along(sp_tmp)) {
    sp_tmp[[i]] <- sp_tmp[[i]][order(sp_tmp[[i]]$date), ]
  }
  tmp <- do.call(rbind, sp_tmp)
  varname <- tmp$varname
  index <- tmp$index
  date <- tmp$date
  ncases <- tmp$ncases
  formula<-match.call(extract_bs)
  csign <- NULL
  nrecords<- length(varname)
  if (is.null(ncases)) ncases<- rep(0,nrecords)
  moddate <- date #create temporary date vector, leaving original unmodified
  if ((unit=="A" || unit=="O") && endmonth<12) {
    for (i in 1:nrecords) { #first loop through raw data file
      month<- month(moddate[i])
      year<- year(moddate[i])
      if (month>endmonth) moddate[i]<- ymd(paste(year, "01", "01", sep="-")) #modified date become 1/1 of next year
    } #end loop through data
  } # end if
  
  if (is.na(begindt)) minper<-month(min(moddate)) else minper<-month(begindt)
  if (is.na(begindt)) miny<-year(min(moddate)) else miny<-year(begindt)
  if (is.na(begindt)) minday<-day(min(moddate)) else minday<-day(begindt)
  if (is.na(enddt)) maxper<-month(max(moddate)) else maxper<-month(enddt)
  if (is.na(enddt)) maxy<-year(max(moddate)) else maxy<-year(enddt)
  if (is.na(enddt)) maxday<-day(max(moddate)) else maxday<-day(enddt)
  if (unit=="Q") {
    minper<- as.integer((minper-1)/3)+1
    maxper<- as.integer((maxper-1)/3)+1
  }
  # mindate<- ISOdate(miny,minper,minday,0,0,0,tz="GMT")
  # maxdate<- ISOdate(maxy, maxper, maxday,0,0,0,tz="GMT") #86400=24*60*60
  
  mindate <- lubridate::ymd(paste(miny, minper, minday, sep="-"))
  maxdate <- lubridate::ymd(paste(maxy, maxper, maxday, sep="-"))
  
  
  #SETCONS:
  latent<- numeric(1)
  aggratio<- 0
  fb<- 1 #initialize
  auto<- "start"  #meaningless value
  alpha<- 1
  alpha1<- 1
  pass<- 1
  holdtola<- 0.001
  tola<- holdtola
  iter<- 0
  lastconv<- 99999
  wtmean<- 0 #for it=1
  wtstd<- 1
  fract<- 1
  iter_hist <- NULL
  dropped <- NULL
  if (unit=="A") {
    nperiods<- maxy-miny+1
    aggratio<- 1
    months<- 12
  }
  if (unit=="O") {
    years<- mult
    months<- years*12
    aggratio<- 2
    odd<- (maxy-miny+1) %% mult  #mod
    nperiods=as.integer((maxy-miny)/mult) + odd
  }
  if (unit=="M") {
    fract<- 100
    nperiods<- (maxy-miny)*12
    nperiods<- nperiods-12 + (12-minper+1) + maxper
    aggratio<- 1/12
    months<- 1
  }
  if (unit=="Q") {
    aggratio<- 1/4
    months<- 3
    nperiods<- as.integer((maxy-miny)/aggratio)
    nperiods<- nperiods-4 + (4-minper+1) + maxper
    fract<- 10
  }
  if (unit=="D") {
    months=1
    nperiods<- (as.integer(maxdate)-as.integer(mindate)) + 1 
  }
  
  arinv<- 1/aggratio
  aggratio<- months/12
  nrecords<- length(index)
  
  #HERE WE SET UP FUNDAMENTAL DIMENSIONS AND DECLARE VECTORS
  if (fb != 2)  mood<- array(dim=c(3,nperiods))
  vfac<- factor(varname) #make a factor vector
  vlev<- levels(vfac)    #find unique categories
  nvar<- length(vlev)    #how many are there?, includes unusable series
  valid<- numeric(nvar)
  csign<- numeric(nvar)
  vl<- character(nvar)
  r<- numeric(nvar)
  oldr<- rep(1,nvar) # r=1 for all v initially
  
  issue<- array(dim=c(nperiods,nvar))
  count<- numeric(nperiods)
  vl<- numeric(nvar)
  period<- numeric(nperiods)
  converge<- 0
  evalue<- 0
  evalue1 <- 0
  evalue2 <- NULL
  # create numeric variable period, eg, yyyy.0m 
  if (unit=="D") {
    period<-seq(1:nperiods) 
  } else {
    if (months >= 12) {
      for (l in 1:nperiods) { 
        p <- (l - 1) * aggratio
        period[l] <- miny + p
      } #next l
    } else {
      y <- 0
      i <- 0
      my <- miny
      if (minper == 1)  my <- my - 1
      for (l in 1:nperiods) { 
        i<- 1 + ((l-1) %% arinv)
        mq <- minper + i - 1
        mq<- 1 + ((mq-1) %% arinv) 
        if (mq == 1)  y <- y + 1 #first month or quarter, increment year
        period[l] <- my + y + mq / fract
      } # end for
    } #end else
  } # end if
  
  
  agglist<- aggregate(varname,moddate,index,ncases,mindate,maxdate,nperiods,nvar,aggratio,unit,miny,minper) # call aggregate to produce issue matrix
  vl<- agglist$lab #extract two elements of the list from aggregate call
  issue<- agglist$iss
  rm(agglist) #don't need this anymore
  
  #NOW REDUCE ISSUE MATRIX TO ELIMINATE UNUSABLE SERIES (WN<2)
  ndrop<- 0
  nissue<- numeric(nperiods)
  std<- numeric(nperiods)
  for (v in 1:nvar) {
    std[v]<- 0 #default
    nissue[v]<- sum(!is.na(issue[,v])) #criterion is 2 cases for npass=1 or 3 for npass=2
    if (nissue[v]>npass) std[v]<- sqrt(var(issue[,v],na.rm=TRUE)) #this is just a test for variance >0
    if (std[v]<.001) {  #case dropped if std uncomputable (NA) or actually zero (constant)
      ndrop<- ndrop+1
      dropped <- rbind(dropped, data.frame(Dropped = vl[v], N_remain = nissue[v]))
    }
  }
  nvarold<- nvar
  nvar<- nvar-ndrop
  pointer<- 1
  found<- FALSE
  
  for (v in 1:nvar) { #now reduced nvar
    while (found==FALSE && pointer<=nvarold) { #find first valid column and push down
      if (std[pointer]>.001) { #good case, transfer
        issue[,v]<- issue[,pointer]
        vl[v]<- vl[pointer]
        pointer<- pointer+1
        found<- TRUE
      } else {
        pointer<- pointer+1 #bad case, increment pointer
      } #end if
    } #end while
    found<- FALSE
  } #for
  length(vl)<- nvar #reduce  
  length(issue)<- nperiods*nvar  #chop off unused columns
  attr(issue,"dim")<- c(nperiods,nvar)
  N<- numeric(nvar)
  
  #export<<-list(nperiods,nvar,issue)
  
  ms_list <- vector(mode = "list", length=npass)
  for (pass in 1:npass) { #newpass: RESTART FOR SECOND DIMENSION CASE
    if (pass == 2) { #reset iteration control parameters
      iter <- 0
      tola = holdtola
      lastconv <- 99999
      converge<- lastconv
      conv<- converge
    } else {
      av<- numeric(nvar)
      std<- numeric(nvar)
      #      ngood<- 0
      for (v in 1:nvar) { #compute av and std by issue nvar now reduced to good cases
        wn<- as.integer(nperiods-sum(is.na(issue[,v])))
        av[v] <- mean(issue[,v],na.rm=TRUE)
        std[v]<- sqrt(var(issue[,v],na.rm=TRUE) * ((wn - 1)/wn)) #convert to population standard deviation
        issue[,v]<- 100 + 10 * (issue[,v] - av[v])/std[v]  #standardize
        #        ngood<- ngood+1
      }#end for
      ms_list[[pass]] <- list(av=av, std=std)
    }
    #READY FOR ESTIMATION, SET UP AND PRINT OPTIONS INFO     
    out<- as.character(10) #initial length only
    setup <- list(start = miny, end = maxy, nperiods = nperiods, used_series = nvar, unused_series = ndrop, smoothiing=smoothing)
    if(!is.null(minper)){
      setup$minper <- minper
      setup$maxper <- maxper
    }
    for (p in 1:nperiods) {
      count[p]<- sum(!is.na(issue[p,]))
    }
    valid<- rep(1,times=nvar)
    csign<- rep(1,times=nvar)
    auto <- "y"              #iterative estimation on by default
    quit <- 0                #false implies go ahead and estimate
    
    while (iter == 0 || converge > tola) {   #MASTER CONTROL LOOP WHICH ITERATES UNTIL SOLUTION REACHED
      
      for (fb in 1:2) { #    MASTER fb LOOP       fb=1 is forward, 2 backward 
        dominate.out<- dominate(fb,issue,nperiods,nvar,mood,valid,smoothing,alpha, csign)  #master estimation routine
        alpha1<- dominate.out$alpha1
        alpha<- dominate.out$alpha
        mood[fb,]<- dominate.out$latent
      } #next fb
      
      fb <- 3 #average mood from here on
      for (p in 1:nperiods) { #    AVERAGE
        mood[fb, p] <- (mood[1, p] + mood[2, p]) / 2
      } #next p
      moodmean<-mean(mood[3,])
      sdmood<-sd(mood[3,])
      for (p in 1:nperiods) {  #PLACEMENT OF THIS LOOP MAY NOT BE RIGHT
        mood[fb,p] <- ((mood[fb,p] - moodmean) * ws / sdmood) + wm
      } #end for
      
      iter <- iter + 1 
      if (auto == "y") r<- iscorr(issue,mood) else auto <- "y"   #recompute correlations
      
      wtmean<- 0
      wtstd<- 0
      vsum<- 0
      goodvar<- 0
      converge<- 0 #start off default
      evalue<- 0
      totalvar<- 0
      
      for (v in 1:nvar) {
        wn<- nperiods-sum(is.na(issue[,v]))
        if (!is.na(sign(r[v]))) csign[v]<- sign(r[v])
        wn<- nperiods-sum(is.na(issue[,v]))
        if (wn>1) { #sum over variables actually used
          vratio <- wn / nperiods
          evalue <- evalue + vratio * r[v]^2
          totalvar <- totalvar + vratio
        } #end if
        evalue1 <- evalue
        totalvar1 <- totalvar
        #convergence tests
        if (wn > 3) {
          conv <- abs(r[v] - oldr[v])      #conv is convergence test for item=v
          conv <- conv * (wn / nperiods)                #weight criterion by number of available periods
          if (conv > converge)  converge <- conv        #converge is the global max of conv
        } #end if
        if (!is.na(r[v])) oldr[v] <- r[v]
        if (!is.na(r[v])) valid[v] <- r[v]^2
        if (!is.na(av[v])) wtmean <- wtmean + av[v] * valid[v]
        if (!is.na(std[v])) wtstd <- wtstd + std[v] * valid[v]
        if (!is.na(r[v])) vsum <- vsum + valid[v]
      } #end v loop
      
      if (vsum > 0)  wtmean <- wtmean / vsum
      if (vsum > 0)  wtstd <- wtstd / vsum
      if (pass == 1) {
        mean1 <- wtmean
        std1 <- wtstd
        e1=evalue
      } else {
        wtmean <- mean1
        wtstd <- std1 #*unexp
      } #end if
      fbcorr <- cor(mood[1,],mood[2,]) #fnfrontback 
      if (quit != 1) {
        cv<- format(round(converge,4),nsmall=4) 
        itfmt<-format(round(iter),justify="right",length=4)
        iter_hist <- rbind(iter_hist, data.frame(Dimension = paste0("Dimension ", pass), Iter = itfmt, Convergence = cv, Criterion = tola, 
                                                 Reliability = fbcorr, Alphaf = alpha1, Alphab = alpha))
      }
      if (converge > lastconv)  tola <- tola * 2
      lastconv <- converge
      
      auto = "y"  #skip corr on iter=1, set auto on
      
      if (iter >= 50) break #get out of while loop
    } #END MASTER WHILE ITERATION CONTROL LOOP
    
    if (auto == "y" && converge<tola) { #IF WE REACH THIS CODE WE HAVE A FINAL SOLUTION TO BE REPORTED
      if (pass == 1) out1<- out #hold output for 2 dimensional solution
      auto <- "Q"
      quit <- 1                #flag solution reached, last time through
      r<- iscorr(issue,mood)   #final iteration correlations
      if (pass == 1) r1<- r #hold correlations for 2 dimensional solution
      
      if (pass > 1) {
        unexp <- totalvar 
        totalvar <- unexp * totalvar
        evalue <- evalue * unexp
      } #    end if
      
      if (pass == 1) {
        expprop <- evalue / totalvar
        tot1 <- totalvar
        tot_var <- tot1
        expprop1 <- expprop
      } else {
        erel <- evalue / totalvar          #% exp relative
        totalvar <- (1 - expprop) * tot1   #true var=original var discounted by %exp
        evalue <- erel * totalvar          #rescale to retain %exp relationship
        expprop <- evalue / tot1           #now reduce eral to expprop
        evalue2 <- evalue
        expprop2 <- expprop
      } #    end if
      
      for (v in 1:nvar) {
        N[v]<- sum(!is.na(issue[,v]))
      }
      var.out<- list(varname=vl,loadings=r,means=av,std.deviations=std)
      if (pass !=  2 && npass>1) {
        for (v in 1:nvar) { 
          valid[v] <- 0               #reset all, regmoodissue will set good=1
          if (csign[v] != 0)  issue[,v]<- residmi(issue,v,mood)   #regmoodissue()
        } #v loop
      }  # if
      #begin prn output routine # mood[fb,] is now our estimate,    WHAT ABOUT A SECOND DIMENSION
      
      var_exp <- data.frame(Dimension =  "Dimension 1", 
                            Variance = evalue1, 
                            Proportion = expprop1)
      if(!is.null(evalue2)){
        var_exp <- rbind(var_exp, 
                         data.frame(Dimension = "Dimension 2", 
                                    Variance = evalue2, 
                                    Proportion = expprop2))
      }
      
      latent<- mood[fb,] #vector holds values for output
      if (pass == 1) latent1<- latent #hold first dimension
      #for Zelig output
      if (npass==1) {
        extract.out<- list(call=formula,
                           T=nperiods,
                           nvar=nvar,
                           unit=unit,
                           dimensions=npass,
                           period=period,
                           varname=vl,
                           N=N,
                           wtdmean=wtmean,
                           wtdstd=wtstd,
                           means=av,
                           std.deviations=std,
                           setup1=out1,
                           loadings1=r1,
                           latent1=latent1, 
                           hist = iter_hist, 
                           totalvar = totalvar1, 
                           var_exp = var_exp, 
                           dropped=dropped, 
                           smoothing = smoothing, 
                           ms_list = ms_list)
      } else {
        extract.out<- list(call=formula,
                           T=nperiods,
                           nvar=nvar,
                           unit=unit,
                           dimensions=npass,
                           period=period,
                           varname=vl,
                           N=N,
                           wtdmean=wtmean,
                           wtdstd=wtstd,
                           means=av,
                           std.deviations=std,
                           setup1=out1,
                           loadings1=r1,
                           latent1=latent1,
                           setup2=out,
                           loadings2=r,
                           latent2=latent, 
                           hist = iter_hist,
                           totalvar = totalvar1, 
                           var_exp = var_exp, 
                           dropped=dropped, 
                           smoothing = smoothing, 
                           ms_list = ms_list)
      }
    } #end if auto="y" 
  } #end of for pass=1,2 loop 
  
  # par(col=1) #reset on termination
  class(extract.out)<- "extract"
  return(extract.out)
}



