# Copyright 2006 Université de Liège, Nicolas Mazziotta, 
# sous les termes de la licence GPL2

# Utilities

khprintid <- function(tb=NULL, onefile=TRUE, compile=TRUE, extend=FALSE, bare=FALSE, focus=TRUE) {
	switch<-''
	if (!compile) { 
		switch<-' -l '
	}
	if (extend==T) { 
		switch<-paste(switch, '-x ')
	}
	if (bare==TRUE) {
		switch<-paste(switch, '-b -s ')
	}
	
	if (onefile & !bare) {
		files<-c("")
		for (i in 1:dim(tb)[1]) {
			files<-paste(files, " '", tb[i,"RF"],'#',tb[i,"RI"],"'",sep='')
		}
		return(system(paste("$HOME/bin/khprintid", switch, files,sep=""), ign=T, int=T))
	} 
	else {
		out<-c()
		for (i in 1:dim(tb)[1]) {
			out<-c(out, paste(system(paste("$HOME/bin/khprintid", switch, "'", tb[i,"RF"],'#',tb[i,"RI"],"'",sep=''), ign=T, int=T)))
			out<-c(out, '\n\n')
		}
		return(out)
	}
}

khvim <- function(tb=NULL) {
	for (i in 1:dim(tb)[1]) {
		system(paste('gvim -c /id=.', tb[i,"RI"]," '", tb[i,"RF"],"'",sep=''), ign=F)
	}
}

khedit <- function(tb=NULL) {
	for (i in 1:dim(tb)[1]) {
		system(paste("$HOME/bin/khedit '", tb[i,"RF"],'#',tb[i,"RI"],"' > /dev/null",sep=''), ign=T)
	}
}

avis <- function (msg, level=1) {
	if (level<2) {
		#msg=gsub("(\\w*)", "\\U\\1", msg ,perl=T)
		underline=gsub("(.)", "-", msg ,perl=T)
		msg=paste("\n",msg,"\n",underline,"\n")
		
	}
	cat(paste(msg,"\n",sep=""))
}

catlat <-function (...) {
	out<-iconv(...,"UTF-8","ISO-8859-1")
	#out<-gsub("\n$", "", out)
	return(cat(out))
}

output <- function (
	tt, 
	dudi=dudi.acm, 
	pattern=NULL, 
	tris=TRUE, 
	croise=TRUE,
	plat=TRUE,
	afc=TRUE,
	supvars=NULL,
	nf=6,
	pem.do=TRUE,
	tdl.do=TRUE,
	spec=NULL
) {
	data<-NULL
	# pattern = le patron à employer pour créer les fichiers temporaires
		if (is.null(pattern)) {
			pattern<-paste(colnames(tt), sep='-', collapse='-')
		} 
		avis(paste('Traitement:', pattern), level=2);

		basename<-paste("out/",pattern,"", sep="")
		system(paste("mkdir -p ", basename, sep=""))

		tmptxttrisplat<-paste(basename,"/trisPlats.txt",sep="")
		tmptxttriscroise<-paste(basename,"/trisCroises.txt",sep="")

		unlink(tmptxttrisplat)
		unlink(tmptxttriscroise)

	# Effectif
							tmptex<-paste(basename,"/n.tex", sep="")
							sink(tmptex)
							cat(dim(tt)[1])
							sink()

	if (tris == TRUE) {
	# Tris
		cat("  Tris\n")
		tris<-tris(tt, pem.do=pem.do, tdl.do=tdl.do, plat=plat, croise=croise);

		
		if (is.null(tris$croise)==FALSE) {
			
			triscroise<-tris$croise
			#ps
			tmpps<-paste(basename,"/bertin.ps",sep="")
			unlink(tmpps)
			plot(triscroise, file=paste(tmpps,sep=""), fam="Times", o=T, device=postscript, title='Tris croisés (Bertin)')
			# txt
			sink(tmptxttriscroise, a=T)
			print(toTxt(triscroise))
			sink()
			# tex
			if (class(triscroise)=="tricroise") {
				tmptex<-paste(basename,"/trisCroise.tex", sep="")
				sink(tmptex)
				cat(toLatex(triscroise))
				sink()
			} else {
				names<-names(triscroise)
				for (i in 1:length(names)) {
					xtab_names<-names(triscroise[[i]])
						for (j in 1:length(xtab_names)){
							tmptex<-paste(basename,"/trisCroise-",names[i],"x",xtab_names[j],".tex", sep="")
							sink(tmptex)
							cur_tri<-triscroise[[i]][[j]]
							cat(toLatex(cur_tri, caption=paste(pattern, ", tabulation ", names[i]," $\\times$ ",xtab_names[j], sep="")))
							sink()
						}
				}
			}
		}

		if (is.null(tris$plat)==FALSE) {
			trisplat<-tris$plat
			# sink txt
			sink(tmptxttrisplat, a=T)
			print(trisplat)
			sink()
			
			names<-names(trisplat)
			for (i in 1:length(names)) {
				tmptex<-paste(basename,"/trisPlat-",names[i],".tex", sep="")
				sink(tmptex)
				cat(toLatex(trisplat[[i]], caption=paste(pattern, ", tri à plat: ", names[i], sep="")))
				sink()
			}
			
		}
		data$tris<-tris
	}
	if (afc == TRUE) {
	# AFC
		cat("  AFC\n")
		acm<-NULL
		
		# imprimera-t-on les lignes?
		print.row=F

		# de quel type sera l'analyse?
		afc.type<-c("Analyse des correspondances multiples")
		q<-dim(tt)[2]

		if (!is.null(supvars)) {
			dj<-disj(tt)
			dj<-skip(dj, car=supvars)
			acm<-coa(dj, print.row=print.row, scan=F, nf=nf, q=q)
		} else {
			if (q>2) {
				dj<-disj(tt)
				acm<-coa(dj, print.row=print.row, scan=F, nf=nf, q=q)
			} else {
				afc.type<-c("Analyse factorielle des correspondances")
				# on imprime les lignes en cas d'afc simple
				print.row=T
				acm<-coa(as.data.frame(table(tt)[]), print.row=print.row, scan=F, nf=nf)
			}
		}
		summary<-acm$summary #my.summary(acm, r=print.row)


		tmpps<-paste(basename,"/afc.ps",sep="")
		unlink(tmpps)

		tmptxtafc<-paste(basename,"/afc.txt",sep="")
		unlink(tmptxtafc)

		sink(tmptxtafc, a=T)
			fact<-1:3
			flabel<-paste(fact,sep="",collapse="-");
		if (print.row) {
			cat("Points-colonnes\n\n")
			print(summary$cols)
			afcLatex<-toLatex(summary, f=fact, print.rows=print.row, mer=T, caption=paste(pattern, ", points-colonnes sur f", paste(fact, collapse="-f")))
			sink(paste(basename,"/afc-cols.tex", sep=""))
			cat(afcLatex$cols[[flabel]])
			sink()
			cat("\nPoints-lignes\n\n")
			print(summary$ro)
			sink(paste(basename,"/afc-rows.tex", sep=""))
			cat(afcLatex$rows[[flabel]])
			sink()
		} else {
			cat("Modalités actives (points-colonnes)\n\n")
			print(summary$cols)
			afcLatex<-toLatex(summary, f=fact, print.rows=print.row, mer=T)
			sink(paste(basename,"/afc-cols.tex", sep=""))
			cat(afcLatex$cols[[flabel]])
			sink()
		}
		postscript(o=T, file=tmpps, fam="Times", wid=8, hei=8, title="Analyse factorielle (plan)")
		my.plotcoa(acm, r=print.row, file=tmpps, afc.lab=afc.type, ploteig=F)

		if (!is.null(supvars)) {
			cat("\nModalités supplémentaires\n")
			sup<-my.supvar(acm, tt, vars=supvars)
			my.plotsup(sup, a=T)
			my.plotcoa(acm, r=F, file=tmpps, ploteig=FALSE, afc.lab=afc.type)
			my.plotsup(sup, a=F)
			for (i in 1:length(sup)) {
				supdata = sup[[i]];
				cat(paste("\nAxe", names(sup)[i],"\n"))
				supdata=supdata[order(supdata[,"PRB"]),]
				supdata[,"CRD"]=round(supdata[,"CRD"], 3)
				supdata[,"VTS"]=round(supdata[,"VTS"], 3)
				supdata[,"PRB"]=ifelse(supdata[,"CRD"]>0, supdata[,"PRB"], -supdata[,"PRB"])
				supdata[,"PRB"]=format(supdata[,"PRB"])
				sink(paste(basename,"/afc-sup-",names(sup)[i],".tex", sep=""))
				cat(toLatex(supdata, total.rows=F, total.cols=F, caption=paste(pattern, ", modalités supplémentaires, f", names(sup)[i], sep="")))
				sink()
				print(supdata[as.numeric(supdata[,"CRD"])>=0,])
				print(supdata[as.numeric(supdata[,"CRD"])<0,])
			}
		}
		dev.off()

		# Graphique des valeurs propres
		tmpps<-paste(basename,"/afc-eig.ps",sep="")
		postscript(o=T, file=tmpps, family="Times", wid=8, hei=4, title="Analyse factorielle (valeurs propres)")
		my.ploteig(acm, adj=T, norm=T)
		dev.off()

		sink()
		data$afc<-acm
	}
	
	if (!is.null(spec)) {
		cat("  Spécificités\n")
		for (i in 1:length(spec)) {
			tmptxtspec<-paste(basename,"/spec-",spec[i],".txt",sep="")
			spec_table<-spec(tt, col=spec[i]$col, vars=spec[i]$vars)
			sink(tmptxtspec)
			print(spec_table)
			sink()
			for (j in 1:length(spec_table)){
				name<-names(spec_table)[j]
				if (is.null(spec_table[[j]])) {next}
				tmptexspec<-paste(basename,"/spec-",spec[i],"-",name,".tex",sep="")
				sink(tmptexspec)
				cat(toLatex(spec_table[[j]], caption=paste(pattern, ", spécificités de la modalité ",spec[i],".",name, sep="")))
				sink()
			}
		}
	}


	#system(paste("cd ", basename , "; mkdir -p ../ps && for myps in ", '*.ps; do cp $myps', ' ../ps/', pattern, '-$myps 2> /dev/null; done;', sep=""))
	#system(paste("cd ", basename , "; mkdir -p ../txt && for mytxt in ", '*.txt; do cp $mytxt', ' ../txt/', pattern, '-$mytxt 2> /dev/null; done;', sep=""))
	#system(paste("cd ", basename , "; mkdir -p ../tex && for mytex in ", '*.tex; do cp $mytex', ' ../tex/', pattern, '-$mytex 2> /dev/null; done;', sep=""))
	system(paste("cd ", basename , "; mkdir -p tex && for mytex in ", '*.tex; do mv $mytex', ' tex/', pattern, '-$mytex 2> /dev/null; done;', sep=""))

	return(data)
}

# HACKED
boxplot.n<- function (..., top = FALSE, shrink = 1, textcolor = NULL)
{
    boxcall <- match.call()
    boxcall$top <- boxcall$shrink <- boxcall$textcolor <- NULL
    boxcall[[1]] <- as.name("boxplot")
    if (is.R()) {
        box <- eval(boxcall, parent.frame())
        mids <- 1:length(box$n)
    }
    else {
        mids <- eval(boxcall, parent.frame())
        boxcall$plot <- FALSE
        box <- eval(boxcall, parent.frame())
    }
    if (top) {
        where <- par("usr")[4] -1
        adj <- c(0.5, 1)
    }
    else {
        where <- par("usr")[3] +1
        adj <- c(0.5, 0)
    }
    tcex <- par("cex")
    par(cex = shrink * tcex)
		
		
    if (is.R())
        text(x = mids, y = where, labels = paste("n=", box$n,
            sep = ""), adj = adj, col = textcolor)
    else {
        if (is.null(textcolor))
            textcolor <- 1
				space <- ifelse(top, -1, 1) * par("1em")[2]/2 
        text(x = mids, y = where + space, labels = paste("n=",
            box$n, sep = ""), adj = adj[1], col = textcolor)
    }
    par(cex = tcex)
    invisible(box)
}

done <- function(msg=NULL) {
	if (is.null(msg)) msg<-"L\'action entreprise est terminée!"
	system(paste('xmessage -center "', iconv(msg,"UTF-8","ISO-8859-1"),'"'))
}

#vim: encoding=utf-8 fileencoding=utf-8
