.packageName <- "StatMatch"
#line 1 "/private/tmp/Rtmpn5rsqh/R.INSTALL10d63af1/StatMatch/R/NND.hotdeck.R"
`NND.hotdeck` <-
function (data.rec, data.don, match.vars, don.class=NULL, dist.fun="Euclidean", constrained=FALSE, constr.alg=NULL) 
{

    if(dist.fun!="Gower" || dist.fun!="gower" || dist.fun!="exact" || dist.fun!="exact matching"){
		require(proxy)
	}
	if(constrained && constr.alg=="relax"){
		require(optmatch)
	}
	if(constrained && (constr.alg=="lpSolve" || constr.alg=="lpsolve")){
		require(lpSolve)
	}

	p <- length(match.vars)
	if(!is.null(dim(data.rec))){
		nr <- nrow(data.rec)
		r.lab <- row.names(data.rec)
	}
	else{
		nr <- length(data.rec)
		r.lab <- names(data.rec)
	}
	if(!is.null(dim(data.don))){
		nd <- nrow(data.don)
		d.lab <- row.names(data.don)
	}
	else{
		nd <- length(data.don)
		d.lab <- names(data.don)
	}
	
	if(is.null(r.lab)) r.lab <- paste("rec", 1:nr, sep="=")
	else r.lab <- paste("rec", r.lab, sep="=")
	row.names(data.rec) <- r.lab
	
	if(is.null(d.lab)) d.lab <- paste("don", 1:nd, sep="=")
	else d.lab <- paste("don", d.lab, sep="=")
	row.names(data.don) <- d.lab
	
########################
NND.hd <- function (rec, don, dfun="Euclidean", constr=FALSE, c.alg=NULL)
{ 
    if(is.null(dim(rec))) x.rec <- data.frame(rec)
	else x.rec <- rec
    if(is.null(dim(don))) x.don <- data.frame(don)
	else x.don <- don
    p <- ncol(rec)
	nr <- nrow(x.rec)
	nd <- nrow(x.don)
	if(nr>nd) cat("Warning: the no. do donors is less than the no.f recipients", fill=TRUE)

    r.lab <- rownames(x.rec)
	if(is.null(r.lab)) r.lab <- 1:nr
	d.lab <- rownames(x.don)
	if(is.null(d.lab)) d.lab <- 1:nd

# compute matrix of distances between obs. in x.don and obs. in x.rec
# function dist() in package "proxy" is used! 

	if(dfun=="Euclidean" || dfun=="Manhattan"){
		cat("Warning:", dfun, "distance is being used", fill=TRUE)
        cat("Warning: all the categorical variables in rec and don data.frame are recoded into dummies", fill=TRUE)
        x.rec <- fact2dummy(x.rec, all=FALSE)
        x.don <- fact2dummy(x.don, all=FALSE)
        mdist <- dist(x=x.rec, y=x.don, method=dfun)
	}
	else if(dfun=="exact" || dfun=="exact matching"){
		cat("Warning: exact matching distance is being used", fill=TRUE)
		cat("all the matching variables in data.rec and data.don are converted to character variables and treated as categorical nominal", fill=TRUE)
		dxr <- dim(x.rec)
		x.rec <- as.character(as.matrix(x.rec))
		dim(x.rec) <- dxr
		dxd <- dim(x.don)
		x.don <- as.character(as.matrix(x.don))
		dim(x.don) <- dxd
		xx <- data.frame(rbind(x.rec, x.don))
		x.rec <- xx[1:nr,]
		x.don <- xx[-(1:nr),]
		mdist <- gower.dist(data.x=x.rec, data.y=x.don)
	}
	else if(dfun=="Gower" || dfun=="gower"){
		# if(p==1 && is.factor(x.rec)) x.rec <- list(x.rec)
		# if(p==1 && is.factor(x.don)) x.don <- list(x.don)
		mdist <- gower.dist(data.x=x.rec, data.y=x.don)
		mdist[is.nan(mdist)] <- 1 # NaN can occur when p=1 and x.rec and x.don is of type logical
		mdist[is.na(mdist)] <- 1 # NA can occur when p=1 and x.rec and x.don is of type logical
	}
	else{
		mdist <- dist(x=x.rec, y=x.don, method=dfun)
	}
	dimnames(mdist) <- list(r.lab, d.lab)

# UNCONSTRAINED nearest neighbour matching

	if(!constr){
		dist.rd <- numeric(nr)
		nad <- rep(NA, nr)
		don.lab <- numeric(nr)
		for(i in 1:nr){
			vd <- mdist[i,]
			min.d <- min(vd) # smallest distance recipient-donor
			dist.rd[i] <- min.d
			appo <- d.lab[vd==min.d]
			nad[i] <- length(appo) # number of availabe donors
			if(length(appo)==1) don.lab[i] <- appo 
			else don.lab[i] <- sample(appo, 1)
		}
		rec.lab <- r.lab
	}

# CONSTRAINED nearest neighbour matching.
# the functions in library lpSolve are used

	if(constr && (c.alg=="lpSolve" || c.alg=="lpsolve")){
		if(nr==nd) appo <- lp.assign(cost.mat=mdist)
		else if(nr<nd){
                r.sig <- rep("==", nr)
                r.rhs <- rep(1, nr)
                c.sig <- rep("<=", nd)
                c.rhs <- rep(1, nd)
                appo <- lp.transport(cost.mat=mdist, row.signs=r.sig, row.rhs=r.rhs, col.signs=c.sig, col.rhs=c.rhs)
		}   
		else if(nr > nd){
			stop("There more recipients than donors!")
			cat("some donors will be used more than once", fill=TRUE)
			r.sig <- rep("==", nr)
			r.rhs <- rep(1, nr)
			c.sig <- rep(">=", nd)
			c.rhs <- rep(1, nd)
			appo <- lp.transport(cost.mat=mdist, row.signs=r.sig, row.rhs=r.rhs, col.signs=c.sig, col.rhs=c.rhs)
		}
		sol <- appo$solution
		ss <- c(t(sol))
		cc <- c(t(col(sol)))
		dist.rd <- mdist[cbind(1:nr, cc[as.logical(ss)] )]
		rec.lab <- r.lab
		don.lab <- d.lab[c(cc[as.logical(ss)])]
	}

# the function pairmatch() in library optMatch are used
	if(constr && c.alg=="relax"){
		if(nr > nd) stop("pairmatch() function in library optmatch requires the no. 
							of donors to be greater or equal than the no. of recipients")
		out.pr <- pairmatch(mdist)
		labs <- names(out.pr)
		tt <- labs %in% r.lab
		df1 <- data.frame(id.rec=labs[tt], mm=out.pr[tt], stringsAsFactors=FALSE)
		df2 <- data.frame(id.don=labs[!tt], mm=out.pr[!tt], stringsAsFactors=FALSE)
		df <- merge(df1, df2, by="mm")
		rmd <- mdist[df$id.rec, ]
		rmd <- rmd[ ,df$id.don]
		dist.rd <- diag(rmd[1:nr, 1:nr])
		aa <- data.frame(id.rec=r.lab, pos=1:nr, stringsAsFactors=FALSE)
		bb <- merge(aa, df, by="id.rec")
		don.lab <- bb[order(bb$pos) , "id.don"]
		rec.lab <- r.lab
		dist.rd <- dist.rd[order(bb$pos)]
	}
# output
    mtc.ids <- cbind(rec.id=rec.lab, don.id=don.lab)
	if(constr) fine <- list(mtc.ids=mtc.ids, dist.rd=dist.rd, call=match.call())
	else fine <- list(mtc.ids=mtc.ids, dist.rd=dist.rd, noad=nad, call=match.call())
	fine
}
################ NND.hd ends here #############################
	
	if(is.null(don.class)){ 
		out <- NND.hd(rec=data.rec[,match.vars], don=data.don[,match.vars], dfun=dist.fun, constr=constrained, c.alg=constr.alg )
		mmm <- out$mtc.ids
		mmm <- substring(mmm, 5)
		if(is.null(rownames(data.rec)) && is.null(rownames(data.don)))  mtc.ids <- matrix(as.numeric(mmm), ncol=2, byrow=TRUE)
		else mtc.ids <- mmm
		dimnames(mtc.ids) <- list(NULL, c("rec.id", "don.id"))
		dist.rd <- out$dist.rd
		if(!constrained) noad <- out$noad
	}
	else{
		if(length(don.class)==1){
			l.rec <- split(data.rec[ ,match.vars], f=data.rec[ ,don.class])
			l.don <- split(data.don[ ,match.vars], f=data.don[ ,don.class])
		}
		else{
			l.rec <- split(data.rec[ ,match.vars], f=as.list(data.rec[ ,don.class]))
			l.don <- split(data.don[ ,match.vars], f=as.list(data.don[ ,don.class]))
		}
		if(length(l.rec)!=length(l.don)){
			cat("The no. of donation classes in recipient data is not equal to the no. of donation classes in donor data", fill=TRUE)
			stop("Possible reason: the variables used to classify units are not defined as factors or are factors with different levels") 	
		}
		if(!identical(names(l.rec), names(l.don)))
			cat("Warning: the donation classes seem built using different factors with differnt levels")
		if(p==1){
            nn.r <- unlist(lapply(l.rec, length))
            nn.d <- unlist(lapply(l.don, length))
        }
		else {
            nn.r <- unlist(lapply(l.rec, nrow))
            nn.d <- unlist(lapply(l.don, nrow))
        }
        l.rec <- l.rec[nn.r>0]
        l.don <- l.don[nn.r>0]
        nn.r <- nn.r[nn.r>0]
        nn.d <- nn.d[nn.r>0]
        if(any(nn.d==0)) {
			stop("For some donation classes there are NO donors available. Please modify the definition of the donation classes")
		}	
		H <- length(l.rec)
		mtc.ids <- as.list(numeric(H))
		dist.rd <- as.list(numeric(H))
		if(!constrained) noad <- as.list(numeric(H))
		for(h in 1:H){
        out <- NND.hd(rec=l.rec[[h]], don=l.don[[h]], dfun=dist.fun, constr=constrained, c.alg=constr.alg )
        mtc.ids[[h]] <- out$mtc.ids
			  dist.rd[[h]] <- out$dist.rd
			  if(!constrained) noad[[h]] <- out$noad
		}
        mmm <- unlist(lapply(mtc.ids, t))
		mmm <- substring(mmm, 5)
		mtc.ids <- matrix(mmm, ncol=2, byrow=TRUE)
		if(is.null(rownames(data.rec)) && is.null(rownames(data.don)))  mtc.ids <- matrix(as.numeric(mmm), ncol=2, byrow=TRUE)
		dimnames(mtc.ids) <- list(NULL, c("rec.id", "don.id"))
		dist.rd <- unlist(dist.rd)
		if(!constrained) noad <- unlist(noad)
	}
	if(constrained) end.out <- list(mtc.ids=mtc.ids, dist.rd=dist.rd, call=match.call())
	else end.out <- list(mtc.ids=mtc.ids, dist.rd=dist.rd, noad=noad, call=match.call())
	end.out
}

#line 1 "/private/tmp/Rtmpn5rsqh/R.INSTALL10d63af1/StatMatch/R/RANDwNND.hotdeck.R"
`RANDwNND.hotdeck` <-
function (data.rec, data.don, match.vars=NULL, don.class=NULL, dist.fun="Euclidean", cut.don="rot", k=NULL) 
{
	if(dist.fun!="gower" || dist.fun!="Gower" || dist.fun!="exact" || dist.fun!="exact matching"){
		require(proxy)
	}
	
	p <- length(match.vars)
	if(!is.null(dim(data.rec))){
		nr <- nrow(data.rec)
		r.lab <- row.names(data.rec)
	}
	else{
		nr <- length(data.rec)
		r.lab <- names(data.rec)
	}
	if(!is.null(dim(data.don))){
		nd <- nrow(data.don)
		d.lab <- row.names(data.don)
	}
	else{
		nd <- length(data.don)
		d.lab <- names(data.don)
	}
		
	if(is.null(r.lab)) r.lab <- paste("rec", 1:nr, sep="=")
	else r.lab <- paste("rec", r.lab, sep="=")
	row.names(data.rec) <- r.lab
	
	if(is.null(d.lab)) d.lab <- paste("don", 1:nd, sep="=")
	else d.lab <- paste("don", d.lab, sep="=")
	row.names(data.don) <- d.lab

################
RANDwNND.hd <- function (rec, don, dfun="Euclidean", cut.don="rot", k=NULL)
{ 
  if(is.null(dim(rec))) x.rec <- data.frame(rec)
  else x.rec <- rec
  if(is.null(dim(don))) x.rec <- data.frame(don)
  else x.don <- don

  p <- ncol(rec)

	nr <- nrow(rec)
	nd <- nrow(don)
	if(nr>nd) cat("Warning: the no. do donors is less than the no.f recipients", fill=TRUE)

	r.lab <- rownames(rec)
	if(is.null(r.lab)) r.lab <- 1:nr
	d.lab <- rownames(don)
	if(is.null(d.lab)) d.lab <- 1:nd

# compute matrix of distances between obs. in x.don and obs. in x.rec
# function dist() in package "proxy" is used! 

    if(dfun=="Euclidean" || dfun=="Manhattan"){
        cat("The ", dfun, " distance is being used", fill=TRUE)
        cat("Warning: all the categorical variables in rec and don data.frame are recoded into dummies", fill=TRUE)
        x.rec <- fact2dummy(x.rec, all=FALSE)
        x.don <- fact2dummy(x.don, all=FALSE)
        mdist <- dist(x=x.rec, y=x.don, method=dfun)
    }
    else if(dfun=="exact" || dfun=="exact matching"){
        cat("The exact matching distance is being used", fill=TRUE)
        cat(" Warning: all the variables in rec and don data frame are converted to character variables and are treated as categorical nominal", fill=TRUE)
        dxr <- dim(x.rec)
        x.rec <- as.character(as.matrix(x.rec))
        dim(x.rec) <- dxr
        dxd <- dim(x.don)
        x.don <- as.character(as.matrix(x.don))
        dim(x.don) <- dxd
        xx <- data.frame(rbind(x.rec, x.don))
		    x.rec <- xx[1:nr,]
		    x.don <- xx[-(1:nr),]
		    mdist <- gower.dist(data.x=x.rec, data.y=x.don)
    }
    else if(dfun=="Gower" || dfun=="gower"){
        # if(p==1 && is.factor(x.rec)) x.rec <- list(x.rec)
        # if(p==1 && is.factor(x.don)) x.don <- list(x.don)
        mdist <- gower.dist(data.x=x.rec, data.y=x.don)
        mdist[is.nan(mdist)] <- 1 # NaN can occur when p=1 and x.rec and x.don is of type logical
        mdist[is.na(mdist)] <- 1 # NA can occur when p=1 and x.rec and x.don is of type logical
    }
    else mdist <- dist(x=x.rec, y=x.don, method=dfun)
    dimnames(mdist) <- list(r.lab, d.lab)
    
    if(cut.don=="rot"){
        k <- ceiling(sqrt(nd))
    		if(k==0) stop("k=sqrt(no. of dons) is equal to 0")  
    }
    else if(cut.don=="span"){ 
        if(k==0 || k>1) stop("When cut.don=span, k should be such that  0 < k <= 1") 
		    k <- ceiling(nd*k)
		    if(k>nd) k <- nd
		    if(k==0) stop("k=round(no. of dons x k) is equal to 0")
	  } 
    else if(cut.don=="exact") {
	    if(k==0 || k>nd) stop("When cut.don=exact, k should be such that  1 < k <= no. of dons") 
    }
	
    min.d <- numeric(nr)
    max.d <- numeric(nr)
    sd.d <- numeric(nr)
    cut.d <- numeric(nr)
    dist.rd <- numeric(nr)
    nad <- rep(NA, nr)

    don.lab <- numeric(nr)
	for(i in 1:nr){
        vd <- mdist[i,]
        min.dist <- min(vd, na.rm=TRUE) # smallest distance recipient-donor
        min.d[i] <- min.dist
        max.d[i] <- max(vd, na.rm=TRUE)
		sd.d[i] <- sd(vd, na.rm=TRUE)
        if(cut.don=="min"){
            short.vd <- vd[(vd==min.dist) & !is.na(vd)]
            appo <- d.lab[(vd==min.dist) & !is.na(vd)]
            dist.rd[i] <- min.dist
            cut.d[i] <- min.dist
		}	
        else if(cut.don=="k.dist"){
			if(k<min.dist) {
				cat("Warning: the value of k,", k, fill=TRUE)
				cat("is smaller than the minimum distance:", min.d, fill=TRUE)
			}			
			appo <- d.lab[(vd<=k) & !is.na(vd)]
			short.vd <- vd[(vd<=k) & !is.na(vd)]
            cut.d[i] <- k
        }
        else {
            appo <- d.lab[order(vd, na.last=NA)]
			if(length(appo)<k) kk <- length(appo)
			else kk <- k
			appo <- appo[1:kk]
			short.vd <- vd[order(vd, na.last=NA)][1:kk]
            cut.d[i] <- short.vd[kk]
        }

        nad[i] <- length(appo) # number of availabe donors
        if(length(appo)==0) {
            nad[i] <- 0
			don.lab[i] <- NA
			dist.rd[i] <- NA
            cat("Warning: there are no available donors for the", d.lab[i], "recipient!", fill=TRUE)
        }       
        else if(length(appo)==1){
			nad[i] <- 1
			don.lab[i] <- appo 
			dist.rd[i] <- short.vd
		}	
        else{
			nn.dd <- length(appo)
			nad[i] <- nn.dd
			choi <- sample(1:nn.dd, 1)
			don.lab[i] <- appo[choi]
			dist.rd[i] <- short.vd[choi]
		}	
    }       
    rec.lab <- r.lab

# output
    mtc.ids <- cbind(rec.id=rec.lab, don.id=don.lab)
	sum.dist <- cbind(min=min.d, max=max.d, sd=sd.d, cut=cut.d, dist.rd=dist.rd)
	list(mtc.ids=mtc.ids, sum.dist=sum.dist, noad=nad, call=match.call())
}
#########################
# RANDwNND.hd ends here
############################################	

	if(is.null(don.class)){ 
		if(is.null(match.vars)){
			don.lab <- sample(d.lab, nr, replace=TRUE)
			mtc.ids <- cbind(rec.id=r.lab, don.id=don.lab)
			noad <- rep(nd, nr)
			sss.dist <- NULL
		}
		else {
			if(p==1){
				REC <- data.frame(data.rec[, match.vars])
				names(REC) <- match.vars
				row.names(REC) <- r.lab
				DON <- data.frame(data.don[, match.vars])
				names(DON) <- match.vars
				row.names(DON) <-d.lab
			}
			else{
				REC <- data.rec[, match.vars]
				DON <- data.don[, match.vars]
			}
			out <- RANDwNND.hd(rec=REC, don=DON, dfun=dist.fun, cut.don=cut.don, k=k)
			mtc.ids <- out$mtc.ids
			noad <- out$noad
			sss.dist <- out$sum.dist
		}
		mmm <- substring(c(mtc.ids), 5)
		mtc.ids <- matrix(mmm, ncol=2)
		if(is.null(rownames(data.rec)) && is.null(rownames(data.don)))  mtc.ids <- matrix(as.numeric(mmm), ncol=2)
	}
	else{
		if(length(don.class)==1){
			l.r.lab <- split(r.lab, f=data.rec[ ,don.class])
			l.rec <- split(data.rec[ ,match.vars], f=data.rec[ ,don.class])
			l.d.lab <- split(d.lab, f=data.don[ ,don.class])
			l.don <- split(data.don[ ,match.vars], f=data.don[ ,don.class])
		}
		else{
			l.r.lab <- split(r.lab, f=as.list(data.rec[ ,don.class]))
			l.rec <- split(data.rec[ ,match.vars], f=as.list(data.rec[ ,don.class]))
			l.d.lab <- split(d.lab, f=as.list(data.don[ ,don.class]))
			l.don <- split(data.don[ ,match.vars], f=as.list(data.don[ ,don.class]))
		}
		if(length(l.rec)!=length(l.don)){
			cat("The no. of donation classes in recipient data is not equal to the no. of donation classes in donor data", fill=TRUE)
			stop("Possible reason: the variables used to classify units are not defined as factors or are factors with different levels") 	
		}
		if(!identical(names(l.rec), names(l.don)))
			cat("Warning: the donation classes seem built using different factors with differnt levels")
			
		nn.r <- unlist(lapply(l.r.lab, length))
		nn.d <- unlist(lapply(l.d.lab, length))
				
		if(sum((nn.r>0) & (nn.d==0))>0) {
			stop("In some donation classes there are NO available donors. Please modify the definition of the donation classes")
		}	
		l.r.lab <- l.r.lab[nn.r>0]
		l.d.lab <- l.d.lab[nn.r>0]
		l.rec <- l.rec[nn.r>0]
		l.don <- l.don[nn.r>0]
				
		H <- length(l.rec)
		mtc.ids <- as.list(numeric(H))
		sum.dist <- as.list(numeric(H))
		noad <- as.list(numeric(H))
		
		for(h in 1:H){
			if(is.null(match.vars)){
				don.lab <- sample(l.d.lab[[h]], nn.r[[h]], replace=TRUE)
				mtc.ids[[h]] <- cbind(rec.id=l.r.lab[[h]], don.id=don.lab)
				sum.dist[[h]] <- NA
				noad[[h]] <- rep(nn.d[[h]], nn.r[[h]])
			}
			else{
				if(p==1){
					REC <- data.frame(l.rec[[h]])
					row.names(REC) <- l.r.lab[[h]]
					DON <- data.frame(l.don[[h]])
					row.names(DON) <- l.d.lab[[h]]
				}
				else{
					REC <- l.rec[[h]]
					DON <- l.don[[h]]
				}
				out <- RANDwNND.hd(rec=REC, don=DON, dfun=dist.fun, cut.don=cut.don, k=k)
				mtc.ids[[h]] <- out$mtc.ids
				sum.dist[[h]] <- out$sum.dist
				noad[[h]] <- out$noad
			}	
		}
		
		mmm <- unlist(lapply(mtc.ids, t))
		mmm <- substring(mmm, 5)
		mtc.ids <- matrix(mmm, ncol=2, byrow=TRUE)
		if(is.null(rownames(data.rec)) && is.null(rownames(data.don)))  mtc.ids <- matrix(as.numeric(mmm), ncol=2, byrow=TRUE)
		sss.dist <- NA
		if(!is.null(match.vars)){
			
			sss <- unlist(lapply(sum.dist, t))
			sss.dist <- matrix(sss, ncol=5, byrow=TRUE)
			colnames(sss.dist)<- colnames(out$sum.dist)
		}
		noad <- unlist(noad)
	}
	dimnames(mtc.ids) <- list(NULL, c("rec.id", "don.id"))
	list(mtc.ids=mtc.ids, sum.dist=sss.dist, noad=noad, call=match.call())
}

#line 1 "/private/tmp/Rtmpn5rsqh/R.INSTALL10d63af1/StatMatch/R/create.fused.R"
`create.fused` <-
function (data.rec, data.don, mtc.ids, z.vars, dup.x=FALSE, match.vars=NULL) 
{
	r.id <- mtc.ids[,1]
	d.id <- mtc.ids[,2]
	A <- data.rec[r.id,]
	if(dup.x) {
		B <- data.frame(data.don[d.id, c(match.vars, z.vars)])
		lab  <- c(paste(match.vars, "don", sep="."), z.vars)
		names(B) <- lab
	}	
	else {
		B <- data.frame(data.don[d.id, z.vars])
		names(B) <- z.vars
	}	
	AB <- cbind(A, B) 
	row.names(AB) <- row.names(A) 
	AB
}

#line 1 "/private/tmp/Rtmpn5rsqh/R.INSTALL10d63af1/StatMatch/R/fact2dummy.R"
`fact2dummy` <-
function (data, all=TRUE, lab="x") 
{
	dum.fcn <- function(x, all=TRUE){
    fine <- model.matrix(~x-1)
		colnames(fine) <- levels(x)
		if(!all) fine <- fine[,-ncol(fine)]
		fine	} 
	
	if(is.null(dim(data))){
		if(class(data)[1]=="numeric" || class(data)[1]=="integer" || class(data)[1]=="logical") oo <- cbind(1*data)
		else{
			oo <- dum.fcn(data, all=all)
			if(is.null(dim(oo))){
					oo <- matrix(oo)
					colnames(oo) <- paste(lab, 1, sep="")
				}
			colnames(oo) <- paste(lab, colnames(oo), sep="")
		}
	}
	else{
		p <- length(data)
		n <- nrow(data)
		vtype <- lapply(data, class)
		out <- as.list(rep(NA,p))
		
		for(i in 1:p){
			if(vtype[[i]][1]=="numeric" || vtype[[i]][1]=="integer" || vtype[[i]][1]=="logical") {
				aa <- matrix(1*data[,i])
				colnames(aa) <- names(data)[i]
				out[[i]] <- aa
			}	
			else {
				aa <- dum.fcn(data[,i], all=all)
				if(is.null(dim(aa))){
					aa <- matrix(aa)
					colnames(aa) <- paste(names(data)[i], 1, sep="")
				}
				colnames(aa) <- paste(names(data)[i], colnames(aa), sep="")
				out[[i]] <- aa
			}
		}
		oo <- unlist(out)
		oo <- matrix(oo, nrow=n)
		dimnames(oo) <- list(row.names(data), unlist(lapply(out, colnames)))
	}	
	oo
}

#line 1 "/private/tmp/Rtmpn5rsqh/R.INSTALL10d63af1/StatMatch/R/gower.dist.R"
`gower.dist` <-
function (data.x, data.y=data.x, rngs=NULL, KR.corr=TRUE)
{

######
# a function to compute the Gower distance among a two vectors x and y
#
	gower.fcn <- function(x, y, rng=NULL, KR.corr=TRUE)
	{
		nx <- length(x)
		ny <- length(y)
		cx <- class(x) 
		cy <- class(y)
		delta <- matrix(1, nx, ny)
		if(!identical(cx, cy)) stop("the x and y object are of different type")
		if(is.logical(x)){
			dd <- abs(outer(X=x, Y=y, FUN="-"))
			delta[outer(x==FALSE, y==FALSE, FUN="&")] <- 0
			delta[outer(is.na(x), is.na(y), FUN="|")] <- 0
		}
		else if(is.character(x) || (is.factor(x) && !is.ordered(x)) ){
			if(is.factor(x) && !identical(levels(x), levels(y))) stop("x and y have different levels")
			xx <- c(matrix(as.character(x), nx, ny))
			yy <- c(matrix(as.character(y), nx, ny, byrow=TRUE))
			dd <- 1 - outer(x, y, FUN="==")
			delta[outer(is.na(x), is.na(y), FUN="|")] <- 0
		}	
		else if(is.ordered(x)){
			if(KR.corr){
				x <- as.numeric(x)
				y <- as.numeric(y)
				if(is.null(rng) || is.na(rng)) rng <- max(x,y) - 1
				zx <- (x-1)/rng
				zy <- (y-1)/rng
				dd <- abs(outer(X=zx, Y=zy, FUN="-"))/(max(zx,zy)-min(zx,zy) )
				delta[outer(is.na(zx), is.na(zy), FUN="|")] <- 0
			}
			else{
				x <- as.numeric(x)
				y <- as.numeric(y)
				if(is.null(rng) || is.na(rng)) rng <- max(x,y) - 1
				dd <- abs(outer(X=x, Y=y, FUN="-"))/rng
				delta[outer(is.na(x), is.na(y), FUN="|")] <- 0
			}
		}
		else{
  			if(is.null(rng) || is.na(rng)) rng <- max(x,y) - min(x,y)
	 		  dd <- abs(outer(X=x, Y=y, FUN="-"))/rng
		    delta[outer(is.na(x), is.na(y), FUN="|")] <- 0
		}	
		list(dist=dd, delta=delta)
	}
	
#########################################	
	
	if(is.null(dim(data.x)) && is.null(dim(data.y))) {
		out.gow <- gower.fcn(x=data.x, y=data.y, rng=rngs, KR.corr=KR.corr)
		out <- (out.gow$dist	* out.gow$delta) / out.gow$delta
	}
	else if(is.null(dim(data.x)) && !is.null(dim(data.y))){
		p <- ncol(data.y)
		if(length(data.x)!=p) stop("data.x should be of the same length of the no. of cols of data.y")
		num <- array(0, c(1,nrow(data.y),p))
		den <- array(0, c(1,nrow(data.y),p))
		for(k in 1:p){
			if(is.null(rngs)) rng.k <- NULL
			else rng.k <- rngs[k]
			out.gow <- gower.fcn(x=data.x[,k], y=data.y[,k], rng=rng.k, KR.corr=KR.corr)
			num[,,k] <- out.gow$dist*out.gow$delta
			den[,,k] <- out.gow$delta
		}
		out <- apply(num, c(1,2), sum, na.rm=TRUE)/apply(den, c(1,2), sum, na.rm=TRUE)
	}
	else{
		p <- ncol(data.y)
		if(ncol(data.x)!=p) stop("data.x and data.y must have the same no. of cols")
		num <- array(0, c(nrow(data.x), nrow(data.y), p))
		den <- array(0, c(nrow(data.x), nrow(data.y), p))
		for(k in 1:p){
			if(is.null(rngs)) rng.k <- NULL
			else rng.k <- rngs[k]
			out.gow <- gower.fcn(x=data.x[,k], y=data.y[,k], rng=rng.k, KR.corr=KR.corr)
			num[,,k] <- out.gow$dist*out.gow$delta
			den[,,k] <- out.gow$delta
		}
		out <- apply(num, c(1,2), sum, na.rm=TRUE)/apply(den, c(1,2), sum, na.rm=TRUE)
	}
	out
}

#line 1 "/private/tmp/Rtmpn5rsqh/R.INSTALL10d63af1/StatMatch/R/mixed.mtc.R"
`mixed.mtc` <-
function (data.rec, data.don, match.vars, y.rec, z.don, method="ML", rho.yz=0, micro=FALSE, constr.alg="lpSolve")
{
	if((micro & constr.alg=="lpSolve") | (micro & constr.alg=="lpsolve") ) require(lpSolve)
	if((micro & constr.alg=="relax") ) require(optmatch)
	
	if(is.list(data.rec))  data.rec <- data.matrix(data.rec)
	if(is.list(data.don))  data.don <- data.matrix(data.don)
	nA <- nrow(data.rec)	
	nB <- nrow(data.don)
	A.lab <- rownames(data.rec)
	if(is.null(A.lab)) A.lab <- 1:nA
	A.lab <- paste("A", A.lab, sep="=")
	B.lab <- rownames(data.don)
	if(is.null(B.lab)) B.lab <- 1:nB
	B.lab <- paste("B", B.lab, sep="=")
		
	p.x <- length(match.vars)
	x.A <- matrix(c(data.rec[,match.vars]), ncol=p.x)
	pos.x.A <- match(match.vars, colnames(data.rec))
	x.B <- matrix(c(data.don[,match.vars]), ncol=p.x)
	pos.x.B <- match(match.vars, colnames(data.don))
	
# preparing dependent variables Y and Z (assumed to be
# continuous)
	y.lab <- y.rec
	y.A <- data.rec[ ,y.lab]
	
	z.lab <- z.don
	z.B <- data.don[ ,z.lab]
	
	p <- p.x+2
	vc <- matrix(NA, nrow=p, ncol=p) 
	v.names <- c(match.vars, y.lab, z.lab)
	dimnames(vc) <- list(v.names, v.names)
	pos.x <- 1:p.x
	pos.y <- p.x+1
	pos.z <- p.x+2
	if(method=="ML"){

		# regression in file B: Z vs. X
		lm.B <- lm(z.B ~ x.B)
		res.B <- residuals(lm.B)
		se.B <- sqrt(mean(res.B^2))  # ML estimate of V(Z|X)  
		  
		# regression in file A: Y vs. X
		lm.A <- lm(y.A ~ x.A)
		res.A <- residuals(lm.A)
		se.A <- sqrt(mean(res.A^2))  # ML estimate of V(Y|X)  

		# ML estimates for X variables
		mu.x <- colMeans(rbind(x.A, x.B))
		S.x <- var(rbind(x.A, x.B))*((nA+nB-1)/(nA+nB))

		# ML estimates for Y
		mu.y <- sum(coefficients(lm.A)*c(1,mu.x))
		S.yx <- coefficients(lm.A)[-1] %*% S.x
		S.y <- se.A^2 + S.yx %*% solve(S.x) %*%  t(S.yx)

		# ML estimates for Z
		mu.z <- sum(coefficients(lm.B)*c(1,mu.x))
		S.zx <- coefficients(lm.B)[-1] %*% S.x
		S.z <- se.B^2 + S.zx %*% solve(S.x) %*%  t(S.zx)
      
		# ML estimates for Y,Z, given the input value rho.yz for partial.cor[(Y,Z)|X]      
		S.yzGx <- rho.yz * (se.A * se.B) # partial Cov[(Y,Z)|X]
		S.yz <- S.yzGx + S.yx %*% solve(S.x) %*% t(S.zx)
		S.zGyx <- se.B^2 - S.yzGx %*% solve(se.A^2) %*% t(S.yzGx)
		S.yGzx <- se.A^2 - S.yzGx %*% solve(se.B^2) %*% t(S.yzGx)
	
		vc[pos.x, pos.x] <- S.x
		vc[pos.x, pos.y] <- vc[pos.y, pos.x] <- S.yx
		vc[pos.x, pos.z] <- vc[pos.z, pos.x] <- S.zx
		vc[pos.y, pos.y] <- S.y
		vc[pos.z, pos.z] <- S.z
		vc[pos.y, pos.z] <- vc[pos.z, pos.y] <- S.yz
		
		# prepare for output
		mu <- c(mu.x, mu.y, mu.z)
		names(mu) <- v.names
		res.var <- c(S.yGzx=c(S.yGzx), S.zGyx=c(S.zGyx))
		fine <- list(start.prho.yz=rho.yz, mu=mu, vc=vc, cor=cov2cor(vc), res.var=res.var)
	}
	if(method=="MS"){
		# estimates for X variables
		mu.x <- colMeans(rbind(x.B,x.A) )
		S.x <- var(rbind(x.B, x.A))
		
		# estimates for Y
		mu.y <- mean(y.A)
		S.y <- var(y.A)
		S.xy <- var(x.A, y.A)
		

		# estimates for Z	
		mu.z <- mean(z.B)
		S.z <- var(z.B)
		S.xz <- var(x.B,z.B)
		
		
		#fills in the Var-Cov matrix
		vc[pos.x, pos.x] <- S.x
		vc[pos.x, pos.y] <- vc[pos.y, pos.x] <- S.xy
		vc[pos.x, pos.z] <- vc[pos.z, pos.x] <- S.xz
		vc[pos.y, pos.y] <- S.y
		vc[pos.z, pos.z] <- S.z

		# estimation of S.yz
		# step.1 checks if the input value for Cor(Y,Z), rho.yz, is admissible  
		c.xy <- c(cor(x.A, y.A))
		c.xz <- c(cor(x.B, z.B))
		if(p.x==1){
			low.c <- c.xy*c.xz - sqrt( (1-c.xy^2)*(1-c.xz^2) )
			up.c <-  c.xy*c.xz + sqrt( (1-c.xy^2)*(1-c.xz^2) )
		}      
		else{
			ic.x <- solve(cov2cor(S.x))
			mc1 <- matrix( rep(c.xy, p.x), ncol=p.x )
			mc2 <- matrix( rep(c.xz, p.x), ncol=p.x, byrow=TRUE)
			cc <- mc1 * ic.x * mc2
			dd1 <- 1 - sum( mc1 * ic.x * t(mc1) )
			dd2 <- 1 - sum( t(mc2) * ic.x * mc2 )  
			low.c <- sum(cc) - sqrt(dd1*dd2)
			up.c <- sum(cc) + sqrt(dd1*dd2)
		}
		# step.2 checks whether the input value rho.yz for Cor(Y,Z) is addmisible. Otherwise takes the closest admissible value.
		cat("input value for rho.yz is", rho.yz, fill=TRUE)
		cat("low(rho.yz)=", low.c, fill=TRUE)
		cat("up(rho.yz)=", up.c, fill=TRUE)
 		sum.rho.yz <- c(start=rho.yz)
		if( (rho.yz<=up.c) && (rho.yz>=low.c) ) {
			cat("The input value for rho.yz is admissible", fill=TRUE)
		}      
		else{
			cat("Warning: value for rho.yz is not admissible: a new value is chosen for it", fill=TRUE)
			if(rho.yz > up.c) rho.yz <- up.c - 0.01
			if(rho.yz < low.c) rho.yz <- low.c + 0.01
			cat("The new value for rho.yz is ", rho.yz, fill=TRUE)
		}
		S.yz <- rho.yz * sqrt(S.y * S.z)
		sum.rho.yz <- c(sum.rho.yz, low.lim=low.c, up.lim=up.c, used=rho.yz)
		vc[pos.y, pos.z] <- vc[pos.z, pos.y] <- S.yz
		
		fi.3 <- rbind(c(S.xz, S.yz)) %*% solve(vc[c(pos.x,pos.y),c(pos.x,pos.y)]) %*% cbind(c(S.xz, S.yz))
		S.zGyx <- S.z - fi.3
		if(S.zGyx<0) S.zGyx <- 0
		fi.6 <- rbind(c(S.xy, S.yz)) %*% solve(vc[c(pos.x,pos.z),c(pos.x,pos.z)]) %*% cbind(c(S.xy, S.yz))
		S.yGzx <- S.y - fi.6
		if(S.yGzx<0) S.yGzx <- 0
	
	# prepare for output
		mu <- c(mu.x, mu.y, mu.z)
		names(mu) <- v.names
		res.var <- c(S.yGzx=c(S.yGzx), S.zGyx=c(S.zGyx))
		fi <- c(fi.6.y=fi.6, fi.3.z=fi.3)
		fine <- list(rho.yz=sum.rho.yz, mu=mu, vc=vc, cor=cov2cor(vc), phi=fi, res.var=res.var) 
	}
	
	if(micro){
		if(nA>nB) stop("The number of donors is less than the number of recipients")
		if(method=="ML"){
			# Prediction of the values of Z in file A
			z.pred <- mu.z + rbind(vc[pos.z,c(pos.x, pos.y)]) %*%  solve(vc[c(pos.x,pos.y),c(pos.x,pos.y)]) %*%  
																			t(cbind(sweep(x.A, 2, mu.x),y.A-mu.y))
			# Prediction of the values of Y in file B
			y.pred <- mu.y + rbind(vc[pos.y,c(pos.x,pos.z)]) %*% solve(vc[c(pos.x,pos.z),c(pos.x,pos.z)]) %*% 
																		t(cbind(sweep(x.B, 2, mu.x), z.B-mu.z))
			rSS <- vc[c(pos.y,pos.z), c(pos.y,pos.z)]
		}
		else if(method=="MS"){	
			# Prediction of the values of Z in file A
			B.zGxy <- t(rbind(c(S.xz, S.yz)) %*% solve(vc[c(pos.x,pos.y),c(pos.x,pos.y)]))
			z.pred <- mu.z + cbind( t(t(x.A)- mu.x), y.A-mu.y   ) %*% B.zGxy
		
			# Prediction of the values of Y in file B
			B.yGxz <- t(rbind(c(S.xy, S.yz)) %*% solve(vc[c(pos.x,pos.z),c(pos.x,pos.z)]))
			y.pred <- mu.y + cbind( t(t(x.B)-mu.x), z.B-mu.z   ) %*% B.yGxz
			
			S1 <- S2 <- vc
			S1[pos.z, pos.z] <- fi.3
			S2[pos.y, pos.y] <- fi.6
			SS <- S1+S2
			rSS	<- SS[c(pos.y,pos.z), c(pos.y,pos.z)]
		}
		irSS <- solve(rSS)
		z.ep <- c(z.pred) + rnorm(nA, 0, sqrt(S.zGyx)) 
		y.ep <- c(y.pred) + rnorm(nB, 0, sqrt(S.yGzx))
		new.B <- cbind(y.ep, z.B)
		madist <- matrix(0, nA, nB)
		for(i in 1:nA){
			new.A <- c(y.A[i], z.ep[i])
			madist[i,] <- mahalanobis(new.B, new.A, irSS, inverted=TRUE)
		}
		dimnames(madist) <- list(A.lab, B.lab)
		# constrained nearest neighbour matching matching is performed
		# using functions in library lpSolve (only small problems)
        if(constr.alg=="lpSolve"){
            
            if(nA==nB) appo <- lp.assign(cost.mat=madist)
            else if(nA<nB){
				r.sig <- rep("==", nA)
				r.rhs <- rep(1, nA)
				c.sig <- rep("<=", nB)
				c.rhs <- rep(1, nB)
				appo <- lp.transport(cost.mat=madist, row.signs=r.sig, row.rhs=r.rhs, col.signs=c.sig, col.rhs=c.rhs)
            }   
            sol <- appo$solution
            ss <- c(t(sol))
            cc <- c(t(col(sol)))
            dist.rd <- madist[cbind(1:nA, cc[as.logical(ss)] )]
            don.lab <- B.lab[c(cc[as.logical(ss)])]
        }

		# the function pairmatch() in library optMatch are used
        else if(constr.alg=="relax"){
                if(nA > nB) stop("pairmatch() function in library optmatch requires the no. 
                                                        of donors to be greater or equal than the no. of recipients")
                out.pr <- pairmatch(madist)
                labs <- names(out.pr)
                tt <- labs %in% A.lab
                df1 <- data.frame(id.rec=labs[tt], mm=out.pr[tt], stringsAsFactors=FALSE)
                df2 <- data.frame(id.don=labs[!tt], mm=out.pr[!tt], stringsAsFactors=FALSE)
                df <- merge(df1, df2, by="mm")
                rmd <- madist[df$id.rec, ]
                rmd <- rmd[ ,df$id.don]
                dist.rd <- diag(rmd[1:nA, 1:nA])
                aa <- data.frame(id.rec=A.lab, pos=1:nA, stringsAsFactors=FALSE)
                bb <- merge(aa, df, by="id.rec")
                don.lab <- bb[order(bb$pos) , "id.don"]
                dist.rd <- dist.rd[order(bb$pos)]
        }
		
		rec.lab <- substring(A.lab, 3)
		don.lab <- substring(don.lab, 3)
		if(is.null(rownames(data.don))) {
			rec.lab <- as.numeric(rec.lab)
			don.lab <- as.numeric(don.lab)
		}
		mtc.ids <- cbind(rec.id=rec.lab, don.id=don.lab)
		fill.A <- cbind(data.rec, data.don[don.lab, z.lab])
		colnames(fill.A) <- c(colnames(data.rec), z.lab)
		
		#output
		fine$filled.rec <- fill.A
		fine$mtc.ids <- mtc.ids
		fine$dist.rd <- dist.rd
		
	}
	fine$call <- match.call()
  fine
}

