# Yuan Yuan, 2015-03-11
# weighted test agains continuous response variables, such as gene expression

# drawback: the ylabel of the inversed plot is negative, can be edited in AI
library(ggplot2)
library(grid)
library(gridExtra)
library(gtable)
hist.mirror2 <- function(data.plot, label)
    {
        myplot <- ggplot(data.plot, aes(ps, fill=status))+geom_histogram(data=subset(data.plot, status=="Yes"), aes(ps, y=..count..))+
            geom_histogram(data=subset(data.plot,status=="No"), aes(ps, y= -..count..))+
                scale_fill_hue(label)+
                    labs(x="Propensity Score")
        print(myplot)
    }

weight.test <- function(data,form, molecular.pri, is.continuous=TRUE, weight="ATT", mirror.plot=FALSE,cancer, data.type, outdir=".", perm=FALSE, seed=seed)
    {
        rownames(molecular.pri) <- gsub("\\.","\\-",rownames(molecular.pri))
        common <- intersect(rownames(data), rownames(molecular.pri))
        print(paste("Number of samples:", length(common)))

        molecular.common <- molecular.pri[match(common, rownames(molecular.pri)),]
        clinical.common <- data[match(common, rownames(data)),]
        print(summary(factor(clinical.common$Z)))
        # write sample info to file
        write.table(t(rbind(rownames(clinical.common),ifelse(clinical.common$Z==1, "High_Autophagy","Low_Autophagy"))), file=paste(cancer,"_",data.type,"_samples.txt", sep=""),quote = F,row.names = F,sep="\t")

        print("----------------")

        age.cutoff <- 65
        print(paste("age <", age.cutoff,":", length(which(clinical.common$age_at_initial_pathologic_diagnosis< age.cutoff))))
        print(paste("age >=", age.cutoff,":", length(which(clinical.common$age_at_initial_pathologic_diagnosis>= age.cutoff))))
        print("----------------")

        if(perm)
            {
                n <- nrow(clinical.common)
                set.seed(seed)
                perm <- sample(1:n,n)
                clinical.common$Z <- clinical.common$Z[perm]
            }

        print(paste("Weighting scheme:", weight))
        source("/home/cliu18/liucj/github/RstudioWithGit/autophagy_codes/13_afh_vs_afl/yy_code/GIPW_function_omega.R")
        ans <- GIPW.std.omega(dat=clinical.common, form.ps=form, weight=weight,trt.est=F)
        # draw mirror plot

        if(mirror.plot)
            {
                ps <- ans$ps
                status <- ifelse(clinical.common$Z==1, "Yes","No")
                data.plot <- data.frame(ps, status )
                pdf(paste(outdir,"/",cancer,"_", data.type, ifelse(perm,paste("_perm_",seed, sep=""), ""),"_mirror_raw.pdf",sep=""))
                if(analysis=="omt")
                    {
                        label="OMT"
                    }
                if(analysis=="gender")
                    {
                        label="Female"
                    }
                if(analysis=="race")
                    {
                        label="Non-White"
                }
                if(analysis=="myclusters"){
                  label = "High_Autophagy"
                }
                print(hist.mirror2(data.plot, label))
                dev.off()
            }
        wt <- ans$W
        source("/home/cliu18/liucj/github/RstudioWithGit/autophagy_codes/13_afh_vs_afl/yy_code/check_balance.r")
        index.tr <- which(clinical.common$Z==1)
        index.ctr <- which(clinical.common$Z==0)

        cutoff=0.1 # 10%
        for (i in 2:(ncol(clinical.common)-1))
            {
                 print(paste("check", colnames(clinical.common)[i]))
                if(nrow(clinical.common[which(clinical.common[,i]==1),]) >=3){
                  #print(summary(clinical.common[,i]))
                  std.diff <- check.balance(index.tr, index.ctr, clinical.common[,i], wt, printout=TRUE)
                  if(std.diff>cutoff)
                  {
                    print(paste("Fail: standardized difference= ", std.diff))
                    print("=======================================")
                    #  stop()
                  }else{
                    print("Pass!")
                  }
                }else{
                  print("too small sample size")
                }

            }

        molecular.pvalues <- c()
        molecular.coefs <- c()
        molecular.0 <- c()
        molecular.1 <- c()
        molecular.0.w <- c()
        molecular.1.w <- c()
        for (i in 1:ncol(molecular.common))
            {
                tmp <- sapply(split(as.numeric(molecular.common[,i]), clinical.common$Z), mean,na.rm=T)
                molecular.0 <- c(molecular.0, tmp[1])
                molecular.1 <- c(molecular.1, tmp[2])
                # get weighted mean
                molecular.0.w <- c(molecular.0.w, sum(as.numeric(molecular.common[index.ctr,i])*wt[index.ctr],na.rm=T)/sum(wt[index.ctr],na.rm=T))
                molecular.1.w <- c(molecular.1.w, sum(as.numeric(molecular.common[index.tr,i])*wt[index.tr],na.rm=T)/sum(wt[index.tr],na.rm=T))
                #print(i)
                if (i%%1000==0)
                    {
                        print(i)
                    }

                if(is.continuous)
                    {
                        #pvalue <- try(summary(lm(clinical.common$Z~molecular.common[,i], weights=wt))$coef[2,4])
                        pvalue <- try(summary(lm(molecular.common[,i]~clinical.common$Z, weights=wt))$coef[2,4])
                        coef <- try(summary(lm(molecular.common[,i]~clinical.common$Z, weights=wt))$coef[2,1])

                        if (class(pvalue)=="try-error")
                            {
                                pvalue <- NA
                                coef <- NA
                            }
                    }else{

                        #pvalue <- summary(glm(clinical.common$Z~molecular.common[,i], family=binomial, weights=wt))$coef[2,4]
                        pvalue <- summary(glm(as.numeric(molecular.common[,i])~clinical.common$Z, family=binomial, weights=wt),na.rm=T)$coef[2,4]
                        coef <- summary(glm(as.numeric(molecular.common[,i])~clinical.common$Z, family=binomial, weights=wt),na.rm=T)$coef[2,1]
                        if (class(pvalue)=="try-error")
                            {
                                pvalue <- NA
                                coef <- NA
                            }
                    }
                molecular.pvalues <- c(molecular.pvalues, pvalue)
                molecular.coefs <- c(molecular.coefs, coef)
            }
        molecular.fdr <- p.adjust(molecular.pvalues,"fdr")
        return(list(feature=colnames(molecular.common),coef=molecular.coefs, pvalue=molecular.pvalues,fdr=molecular.fdr , mean.0= molecular.0, mean.1= molecular.1, mean.0.w=molecular.0.w, mean.1.w=molecular.1.w))
    }

summarize.fdr <- function(molecular.data, molecular.result, cutoff=0.05, print=FALSE )
    {
        pvalue <- molecular.result$pvalue
        fdr <- molecular.result$fdr
        coef <- molecular.result$coef
        mean.0 <- molecular.result$mean.0
        mean.1 <- molecular.result$mean.1
        mean.0.w <- molecular.result$mean.0.w
        mean.1.w <- molecular.result$mean.1.w
        signif.index <- which(fdr<cutoff)
        print(paste("Features with FDR <", cutoff, "=", length(signif.index)))
        if(print)
            {
                print(cbind(colnames(molecular.data)[signif.index],signif(pvalue[signif.index],3), signif(fdr[signif.index],3), signif(coef[signif.index],3), signif(mean.0[signif.index],3), signif(mean.1[signif.index],3)))
            }
        return(list(feature.sig=colnames(molecular.data)[signif.index], pvalue.sig=pvalue[signif.index], fdr.sig= fdr[signif.index], n.sig=length(signif.index), coef.sig=coef[signif.index], mean0.sig=mean.0[signif.index], mean1.sig=mean.1[signif.index], mean0.sig.w=mean.0.w[signif.index], mean1.sig.w=mean.1.w[signif.index]))#, n.sig=length(which(molecular.result$pvalue<cutoff))) )

    }

rm.zero.col <- function(molecular.data)
    {
        ## remove non-coding genes
        genes.raw <- colnames(molecular.data)
        genes <- unlist(lapply(genes.raw, function(x) unlist(strsplit(x,"[|]"))[1]))
        ids <- as.numeric(unlist(lapply(genes.raw, function(x) unlist(strsplit(x,"[|]"))[2])))
        if(FALSE) # do not remove any gene
            {
        rm1 <- grep("?", genes, fixed=TRUE) # question mark
        #rm2 <- grep("^MIR", genes) # MIR
        #rm3 <- grep("^SNOR", genes)
        #rm <- c(rm1, rm2, rm3)
        molecular.data <- molecular.data[,-rm1]
        print(paste(length(rm1),"genes were removed."))
    }

        if(FALSE)
            {
                gene.data <- read.table("/extraspace/yyuan3/Lab_share/protein_coding_gene_annotation.tsv",header=TRUE, sep="\t", quote="")
                name.id <- paste(data$Gene, data$ID, sep="|")
                keep.index <- match(gene.data$ID, ids)
                if (length(which(is.na(keep.index)))>0)
                    {
                        stop("Some protein coding genes are not found. Double check!")
                    }
                print(paste("After remove non-coding, total genes:", length(keep.index)))
                ##print(paste(length(rm),"columns were removed because of non-coding."))

                molecular.data <- molecular.data[,keep.index]
            }

        # remove non-variable genes, i.e., sd=0
        zero.col <- which(apply(molecular.data, 2, sd)==0)
        if (length(zero.col)>0)
            {
                molecular.data <- molecular.data[,-zero.col]
                print(paste(length(zero.col),"columns were removed because of no variation."))
            }

        return(molecular.data)
    }

write.summary <- function(summary, cancer, analysis, type)
    {
        file <- paste(cancer,"_",analysis,"_summary_",type,".txt", sep="")
        data <- data.frame(summary$feature.sig, summary$fdr.sig, summary$coef.sig, summary$mean0.sig, summary$mean1.sig, summary$mean0.sig.w, summary$mean1.sig.w)
        if (analysis=="gender")
            {
                colnames(data) <- c("feature","fdr","coef","mean_MALE", "mean_FEMALE", "mean_MALE_weighted", "mean_FEMALE_weighted")
            }
        if(analysis=="race")
            {
                colnames(data) <- c("feature","fdr","coef","mean_nonWHITE", "mean_WHITE","mean_nonWHITE_weighted", "mean_WHITE_weighted")
            }
        if (analysis=="omt")
            {
                colnames(data) <- c("feature","fdr","coef","mean_nonOMT", "mean_OMT","mean_nonOMT_weighted", "mean_OMT_weighted")
            }
        write.table(data,file=file, quote=FALSE, sep="\t", col.names=TRUE, row.names=FALSE)
    }

write.result <- function(result, cancer, analysis, type, fdr.cutoff=0.05)
    {
        file <- paste(cancer,"_",analysis,"_result_",type,".txt", sep="")
        data <- data.frame(result$feature, result$pvalue, result$fdr, result$coef, result$mean.0, result$mean.1, result$mean.0.w, result$mean.1.w)
        if (analysis=="gender")
            {
                colnames(data) <- c("feature","pvalue","fdr","coef","mean_MALE", "mean_FEMALE", "mean_MALE_weighted", "mean_FEMALE_weighted")
            }
        if(analysis=="race")
            {
                colnames(data) <- c("feature","fdr","coef","mean_nonWHITE", "mean_WHITE","mean_nonWHITE_weighted", "mean_WHITE_weighted")
            }
        if (analysis=="omt")
            {
                colnames(data) <- c("feature","fdr","coef","mean_nonOMT", "mean_OMT","mean_nonOMT_weighted", "mean_OMT_weighted")
            }
        write.table(data,file=file, quote=FALSE, sep="\t", col.names=TRUE, row.names=FALSE)
    }

plot.perm <- function(perm, n, cancer, analysis, type, cutoff)
    {
        p=length(which(perm>= n))/length(perm)
        print(paste("Permutation P-value =", p))
        print(paste(type,": n.sig =", n))
        print(paste("Median perm n.sig =", median(perm)))
        file <- paste(cancer,"_",analysis,"_perm_",type,"_",cutoff,".pdf", sep="")
        pdf(file, width=3, height=3)
        par(mgp=c(2,1,0))
        if(type=="mut") {main="Mutation"}
        if(type=="cnv") {main="SCNA"}
        if(type=="methy") {main="Methy"}
        if(type=="mRNAseq") {main="mRNA"}
        if(type=="miRNA") {main="miRNA"}
        if(type=="rppa") {main="Protein"}
        if (n > max(perm))
            {
                myhist <- hist(perm, xlim=c(0, max(max(perm),n)), main="", xlab="# Genes" )

            }else{
                myhist <- hist(perm, main="", xlab="# Genes")
            }
        text(n, max(myhist$counts),paste("p-value =", p), pos=ifelse(n> 0.5* max(perm),2,4), col=ifelse(p<=0.05, "red","blue"), cex=1.1, xpd=T)
        abline(v=n, col=ifelse(p<=0.05, "red","blue"), lty=2, lwd=2)
        dev.off()
    }

perm.cal <- function(cancer, analysis, type, molecular.pri, cutoff=0.05, seedV=1:100)
    {
        print(paste("Calculate permutation for", cancer,":",type,":"))
      #  load(file=paste(cancer,"_", analysis,"_result.RData",sep=""))
        result <- get(paste(type,".result", sep=""))
        summary <- summarize.fdr(molecular.pri, result, cutoff=cutoff )
        n <- summary$n.sig
        perm <- c()
        print("For permutation:")
        for (seed in seedV)
            {
                ##print(seed)
                perm.result <- perm.summary <- c()
                 if(type=="mut")
                     {
                         load(paste(scripts.dir, "/",cancer,"_",analysis,"/perm_sig_result_",seed,".RData", sep=""))
                     }else if(type=="pre")
                          {
                              load(paste(scripts.dir, "/",cancer,"_",analysis,"/perm_sig_result_pre_",seed,".RData", sep=""))
                          }else{

                              load(paste(scripts.dir, "/",cancer,"_",analysis,"/perm_sig_result_",seed,".RData", sep=""))
                          }
                perm.result <- get(paste("perm.",type,".result", sep=""))
                perm.summary <- summarize.fdr(molecular.pri, perm.result, cutoff=cutoff )
                perm <- c(perm, perm.summary$n.sig)
                do.call(rm, list(paste("perm.",type,".result", sep="")))

            }
        ##print (perm)
        ##print (n)
        plot.perm(perm, n, cancer, analysis, type, cutoff)
    }

# only for mRNAseq, only write the protein coding genes, adjust fdr accordingly
keep.coding <- function(mRNAseq.result,cancer)
    {
        genes.raw <- mRNAseq.result$feature
        genes <- unlist(lapply(genes.raw, function(x) unlist(strsplit(x,"[|]"))[1]))
        ids <- as.numeric(unlist(lapply(genes.raw, function(x) unlist(strsplit(x,"[|]"))[2])))
        gene.data <- read.table("/rsrch1/bcb/yyuan3/extraspace/yyuan3/Lab_share/protein_coding_gene_annotation.tsv",header=TRUE, sep="\t", quote="")
        name.id <- paste(gene.data$Gene, gene.data$ID, sep="|")
        keep.index <- match(gene.data$ID, ids)
        print(paste("After remove non-coding, total genes:", length(keep.index)))
        out <- data.frame(mRNAseq.result)[keep.index,]
        #out$feature <- as.vector(out$feature)
        out$fdr <- p.adjust(out$pvalue, "fdr")
        colnames(out) <- c("feature","coef","pvalue","fdr","mean_MALE", "mean_FEMALE", "mean_MALE_weighted", "mean_FEMALE_weighted")
        write.table(out, file=paste(cancer,"_gender_result_mRNAseq_coding.txt", sep=""), sep="\t", quote=FALSE,row.names=FALSE)

    }

## t-test
myttest <- function(data, molecular.pri, cancer, data.type, perm=FALSE, seed=seed)
    {

      common <- intersect(rownames(data), rownames(molecular.pri))
        print(paste("Number of samples:", length(common)))
        molecular.common <- molecular.pri[match(common, rownames(molecular.pri)),]
        clinical.common <- data[match(common, rownames(data)),]
        print(summary(factor(clinical.common$Z)))
        print("----------------")

        if(perm)
            {
                n <- nrow(clinical.common)
                set.seed(seed)
                perm <- sample(1:n,n)
                clinical.common$Z <- clinical.common$Z[perm]
            }

        molecular.pvalues <- c()
        molecular.coefs <- c()
        molecular.0 <- c()
        molecular.1 <- c()
         for (i in 1:ncol(molecular.common))
             {
                 tmp <- by(molecular.common[,i], clinical.common$Z, mean)
                 molecular.0 <- c(molecular.0, tmp[1])
                 molecular.1 <- c(molecular.1, tmp[2])
                 if (i%%1000==0)
                    {
                        print(i)
                    }
                 result <- try(t.test(molecular.common[,i]~clinical.common$Z))
                 if (class(result)=="try-error")
                     {
                         pvalue <- coef <- NA
                     }else{

                         pvalue <- result$p.value
                         coef <- result$statistic
                     }
                 molecular.pvalues <- c(molecular.pvalues, pvalue)
                 molecular.coefs <- c(molecular.coefs, coef)
             }
        molecular.fdr <- p.adjust(molecular.pvalues,"fdr")
        return(list(feature=colnames(molecular.common),coef=molecular.coefs, pvalue=molecular.pvalues,fdr=molecular.fdr , mean.0= molecular.0, mean.1= molecular.1))

    }

format.barcode <- function(samples)
    {

        samples.new <- unlist(lapply(samples, function(x) paste(unlist(strsplit(x, "-"))[1:3], collapse="-")))
        types <- unlist(lapply(samples, function(x) paste(unlist(strsplit(x, "-"))[4], collapse="-")))
        print(summary(as.factor(types)))
        types[substr(types, 1,2)=="01" | substr(types, 1,2)=="03"] <- "primary"
        types[substr(types, 1,2)=="02"] <- "recurrent"
        types[substr(types, 1,2)=="06"] <- "metastatic"
        types[substr(types, 1,2)=="11"| substr(types, 1,2)=="10"] <- "normal"
        return(list(barcodes=samples.new, types=types))

    }

format.mature <- function(mature.raw)
    {
        samples <- format.barcode(rownames(mature.raw))
        ## only primary cancer will be used for downstream analysis
        ## KIRC has two 05: additinoal- new primary
        mature.pri <- mature.raw[samples$types=="primary",,drop=FALSE]
        mature.rec <- mature.raw[samples$types=="recurrent",,drop=FALSE]
        mature.met <- mature.raw[samples$types=="metastatic",,drop=FALSE]
        mature.normal <- mature.raw[samples$types=="normal",,drop=FALSE]
        rownames(mature.pri) <- samples$barcodes[samples$type=="primary"]
        rownames(mature.rec) <- samples$barcodes[samples$type=="recurrent"]
        rownames(mature.met) <- samples$barcodes[samples$type=="metastatic"]
        rownames(mature.normal) <- samples$barcodes[samples$type=="normal"]
        print(paste("Samples with mature: ", nrow(mature.pri)))
        print(paste("Samples with normal mature: ", nrow(mature.normal)))
        ## fix NA
        min.offset <- 2^min(mature.pri[-which(is.na(mature.pri))])/10
        #min.offset <- 10^-6
        mature.pri <- 2^mature.pri
        mature.pri[is.na(mature.pri)] <- 0
        mature.pri <- log2(mature.pri+min.offset)
        # remove features with no variation
        zero.col <- which(apply(mature.pri, 2, sd)==0)
        if(length(zero.col)>0)
            {
                mature.pri <- mature.pri[,-zero.col]
                print(paste("features removed because of no variation:", length(zero.col)))
            }
        return(mature.pri)
    }

format.pre <- function(pre.raw)
    {
        samples <- format.barcode(rownames(pre.raw))
        ## only primary cancer will be used for downstream analysis
        ## KIRC has two 05: additinoal- new primary
        pre.pri <- pre.raw[samples$types=="primary",,drop=FALSE]
        pre.rec <- pre.raw[samples$types=="recurrent",,drop=FALSE]
        pre.met <- pre.raw[samples$types=="metastatic",,drop=FALSE]
        pre.normal <- pre.raw[samples$types=="normal",,drop=FALSE]
        rownames(pre.pri) <- samples$barcodes[samples$type=="primary"]
        rownames(pre.rec) <- samples$barcodes[samples$type=="recurrent"]
        rownames(pre.met) <- samples$barcodes[samples$type=="metastatic"]
        rownames(pre.normal) <- samples$barcodes[samples$type=="normal"]
        print(paste("Samples with pre: ", nrow(pre.pri)))
        print(paste("Samples with normal pre: ", nrow(pre.normal)))
        ## fix NA
        min.offset <- min(pre.pri[pre.pri!=0])/10
        #min.offset <- 2^min(pre.pri[-which(is.na(pre.pri))])/10
        #min.offset <- 10^-6
        #pre.pri <- 2^pre.pri
        #pre.pri[is.na(pre.pri)] <- 0
        pre.pri <- log2(pre.pri+min.offset)
        # remove features with no variation
        zero.col <- which(apply(pre.pri, 2, sd)==0)
        if(length(zero.col)>0)
            {
                pre.pri <- pre.pri[,-zero.col]
                print(paste("features removed because of no variation:", length(zero.col)))
            }
        return(pre.pri)
    }


code 'G11'
name '流动性比例监测表'
dimensions {
	rowdim {
		dummy true
        hierarchical true
        headModels ([
            [id:101,name:'现金',parentId:1],[id:102,name:'黄金',parentId:1],[id:103,name:'超额准备金',parentId:1],
            [id:104,name:'一个月内同行业往来',parentId:1],[id:105,name:'一个月内应收利息',parentId:1],[id:106,name:'一个月内合格贷款',parentId:1],
            [id:107,name:'一个月内债券投资',parentId:1],[id:108,name:'变现证券透支',parentId:1],[id:109,name:'可变现资产',parentId:1],
            [id:110,name:'流动性资产总和',parentId:1],
            [id:201,name:'活期存款',parentId:2],[id:202,name:'一个月内定期存款',parentId:2],[id:203,name:'一个月同业往来款项',parentId:2],
            [id:204,name:'一个月内已发行债券',parentId:2],[id:205,name:'一个月内应付利息',parentId:2],[id:206,name:'一个月内中央银行借款',parentId:2],
            [id:207,name:'一个月内其他负债',parentId:2],[id:208,name:'流动性负债总和',parentId:2],
            [id:1,name:'流动性资产'],[id:2,name:'流动性负债'],[id:3,name:'流动性比例'],[id:4,name:'本月平均流动性资产'],
            [id:5,name:'本月平均流动性负债'],[id:6,name:'本月平均流动性比列'],
            [id:7,name:'月度最低流动性比例'],[id:8,name:'一个月到期存款金额'],[id:9,name:'用于质押的有关贷款金额']
        ])
    }

    currency {
        text '余额'
		loadErate true
		staticHeads {
			head {
				model ([code:'01',name:'人民币'])
			}
			head {
				derived true
				aggregate true
				model ([code:'foreign',name:'外币折人民币'])
				aggregator {curvs->
					currencyExchange(curvs,'01')
				}
			}
			head {
				derived true
				aggregate true
				model ([code:'sum',name:'本外币合计'])
				formula {
					111111111
				}
			}
		}
	}

}

dataRequest {
    table 'glAllBranch'
    params {
        date 'context[]'
    }
}

dataRequest {
    table 'cfLiquid',allDimensions: ['currency','item','date']
    fields 'sum(balance) value'
    groupFields 'subject_number,currency_code'
    params {
        date 'context[]'
		currency 'context[]'
        staticModel 'context[]'
        liquidGapTerm cw({["<=",context['liquidGapDays']]})
    }
}
//手工维护
dataRequest ManualDataRequest

dataGrids {
	apply sel([rowdim:101,currency:['01','foreign']]), {
        params ([item:'S1001',bal:'debit',dataRequest:'glAllBranch'])
	}
	apply sel([rowdim:102,currency:['01','foreign']]), {
        params ([item:'S1431',bal:'debit',dataRequest:'glAllBranch'])
	}
	apply sel([rowdim:103,currency:['01','foreign']]), {
		formula {
                    v([item:"S1002",bal:'debit',dataRequest:'glAllBranch']) -
                    0.000 //应缴准备金余额
                }
	}
	apply sel([rowdim:104,currency:['01','foreign']]), {
        formula {sumItemsWithMinus(['S1011','S1012','S1013','S1014','S1031','S1111','1404'],['S1032','S2017','S2018','S2019','S2111','S2020'],[dataRequest:'cfLiquid'])}
	}
	apply sel([rowdim:105,currency:['01','foreign']]), {
		formula {sumItems(['S1132','0220','0221'],[dataRequest:'cfLiquid'])}
	}
	apply sel([rowdim:106,currency:['01','foreign']]), {
		formula {sumItems(['S1301','S1302','S1303','S1304','S1306'],[dataRequest:'cfLiquid'])}
	}
	apply sel([rowdim:107,currency:['01','foreign']]), {
		formula {0.000}
	}
	apply sel([rowdim:108,currency:['01','foreign']]), {
		formula {0.000}
	}
	apply sel([rowdim:109,currency:['01','foreign']]), {
        formula {
                sumItems(['1003','1305','1811','1901'],[bal:'debit',dataRequest:'glAllBranch'])+
                mathPositive(v([item:"0031",bal:'debit',dataRequest:'glAllBranch']),v([item:"2006",bal:'credit',dataRequest:'glAllBranch']),0)+
                //下面是手工维护
                v0([dict:'rmblccp1',dataRequest:'manualData'])+
                v0([dict:'rmblccp2',dataRequest:'manualData'])+
                v0([dict:'rmblccp3',dataRequest:'manualData'])
        }
	}
	apply sel([rowdim:110,currency:['01','foreign']]), {
		formula {
            (-9..-1).sum{rowRel(it)}
        }
	}
	apply sel([rowdim:201,currency:['01','foreign']]), {
        formula {sumItems(['2001','2003','2005','1404'],[bal:'credit',dataRequest:'glAllBranch'])}
	}
	apply sel([rowdim:202,currency:['01','foreign']]), {
		formula {sumItems(['S2002','S2004','S2014'],[dataRequest:'cfLiquid'])}
	}
	apply sel([rowdim:203,currency:['01','foreign']]), {
        formula{
            mathPositive(sumItems(['S2017','S2019','S2111'],[dataRequest:'cfLiquid']),sumItems(['S1011','S1013','S1111'],[dataRequest:'cfLiquid']),0)
        }
	}
	apply sel([rowdim:204,currency:['01','foreign']]), {
		formula {sumItems(['S2502'],[dataRequest:'cfLiquid'])}
	}
	apply sel([rowdim:205,currency:['01','foreign']]), {
		formula {sumItems(['S2231','0450','1451','3002'],[dataRequest:'cfLiquid'])}
	}
	apply sel([rowdim:206,currency:['01','foreign']]), {
		formula {sumItems(['2015'],[dataRequest:'cfLiquid'])}
	}
	apply sel([rowdim:207,currency:['01','foreign']]), {
           formula {
                sumItems(['S2007','S2011','SS2012','S2013','S2014','S2101','S2221','S2401','S2711','S2801','S2901','S3031','S30411','S30412','S30413','S30414','S30415','S30416','S30417','S30419','S3051','S3301'],[bal:'credit',dataRequest:'glAllBranch'])+
                mathPositive(sumItems(['S2006'],[bal:'credit',dataRequest:'glAllBranch']),sumItems(['0013'],[bal:'debit',dataRequest:'glAllBranch']),0)-
                sumItems(['S2014'],[dataRequest:'cfLiquid'])
           }
	}
	apply sel([rowdim:208,currency:['01','foreign']]), {
		formula {
            (-7..-1).sum{rowRel(it)}
        }
	}

    //第3列 求和
    apply sel([0..26,2]), {
        formula {colRel(-1)+colRel(-2)}
	}
    //设置这行的文本格式 百分比 3.流动性比例 (项目1.10/项目2.8×100％)
    apply sel([rowdim:3,currency:['01','foreign','sum']]),{
       // dataType new PercentType()
        dataType 'percent'
    }
    //3.流动性比例 (项目1.10/项目2.8×100％)
	apply sel([rowdim:3,currency:['01','foreign','sum']]),{
		formula {rowRel(-10)/rowRel(-1)}
	}
    //4.本月平均流动性资产
	apply sel([rowdim:4,currency:['01','foreign','sum']]),{//目前只是本期的
		formula {rowRel(-11)}
	}
    //5.本月平均流动性负债
	apply sel([rowdim:5,currency:['01','foreign','sum']]),{//目前只是本期的
		formula {rowRel(-3)}
	}
    //设置这行的文本格式 百分比 6.本月平均流动性比例(项目4./项目5.×100％)
    apply sel([rowdim:6,currency:['01','foreign','sum']]),{
       // dataType new PercentType()
        dataType 'percent'
    }
    //6.本月平均流动性比例(项目4./项目5.×100％)
	apply sel([rowdim:6,currency:['01','foreign','sum']]),{
		formula {(rowRel(-2)/rowRel(-1))}
	}
    //7.月度最低流动性比例（％）
	apply sel([24,0..2]), {
		formula {00000.0}
	}
    //8.一个月内到期用于质押的存款金额
	apply sel([25,0..2]), {
		formula {00000.0}
	}
    //9.项目8.用于质押的有关贷款金额
	apply sel([26,0..2]), {
		formula {00000.0}
	}

 //将1.流动性资产 2.流动性负债 所在行，为空
   apply sel([rowdim:[1,2],currency:['01','foreign','sum']]), {
		formula {

        }
	}
}


                         CHAPTER  8

              Functions, Fclosures, and Macros

   8.1.  valid function objects

           There are many different objects which can occupy
      the  function field of a symbol object.  Table 8.1, on
      the following page, shows all  of  the  possibilities,
      how  to recognize them, and where to look for documen-
      tation.

   8.2.  functions

           The basic Lisp function is the  lambda  function.
      When a lambda function is called, the actual arguments
      are evaluated from left to right and are  lambda-bound
      to the formal parameters of the lambda function.

           An nlambda function is usually used for functions
      which  are  invoked  by  the  user at top level.  Some
      built-in functions which evaluate their  arguments  in
      special  ways  are  also  nlambdas (e.g _c_o_n_d, _d_o, _o_r).
      When an  nlambda  function  is  called,  the  list  of
      unevaluated  arguments  is  lambda bound to the single
      formal parameter of the nlambda function.

           Some programmers will  use  an  nlambda  function
      when  they  are  not  sure  how many arguments will be
      passed.  Then, the first thing  the  nlambda  function
      does  is  map  _e_v_a_l over the list of unevaluated argu-
      ments it has been passed.  This is usually  the  wrong
      thing  to  do,  as it will not work compiled if any of
      the arguments are local variables. The solution is  to
      use  a  lexpr.   When  a lexpr function is called, the
      arguments are evaluated and a fixnum  whose  value  is
      the  number of arguments is lambda-bound to the single
      formal parameter of the lexpr function.  The lexpr can
      then access the arguments using the _a_r_g function.

           When a function is compiled, _s_p_e_c_i_a_l declarations
      may  be  needed to preserve its behavior.  An argument
      is not lambda-bound to the name of  the  corresponding
      formal parameter unless that formal parameter has been
      declared _s_p_e_c_i_a_l (see 12.3.2.2).

Functions, Fclosures, and Macros                         8-1

Functions, Fclosures, and Macros                         8-2

8_________________________________________________________________
   informal name             object type          documentation
8__________________________________________________________________________________________________________________________________
    interpreted             list with _c_a_r              8.2
  lambda function           _e_q to lambda
8_________________________________________________________________
    interpreted             list with _c_a_r              8.2
  nlambda function          _e_q to nlambda
8_________________________________________________________________
    interpreted             list with _c_a_r              8.2
   lexpr function            _e_q to lexpr
8_________________________________________________________________
    interpreted             list with _c_a_r              8.3
       macro                 _e_q to macro
8_________________________________________________________________
      fclosure            vector with _v_p_r_o_p            8.4
                           _e_q to fclosure
8_________________________________________________________________
      compiled         binary with discipline          8.2
  lambda or lexpr           _e_q to lambda
      function
8_________________________________________________________________
      compiled         binary with discipline          8.2
  nlambda function          _e_q to nlambda
8_________________________________________________________________
      compiled         binary with discipline          8.3
       macro                 _e_q to macro
8_________________________________________________________________
      foreign          binary with discipline          8.5
     subroutine          of "subroutine"[|-]
8_________________________________________________________________
      foreign          binary with discipline          8.5
      function            of "function"[|-]
8_________________________________________________________________
      foreign          binary with discipline          8.5
  integer function    of "integer-function"[|-]
8_________________________________________________________________
      foreign          binary with discipline          8.5
   real function        of "real-function"[|-]
8_________________________________________________________________
      foreign          binary with discipline          8.5
     C function          of "c-function"[|-]
8_________________________________________________________________
      foreign          binary with discipline          8.5
  double function     of "double-c-function"[|-]
8_________________________________________________________________
      foreign          binary with discipline          8.5
 structure function   of "vector-c-function"[|-]
8_________________________________________________________________
       array                array object                9
8_________________________________________________________________
7|8|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|

9                   |8|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|

9                                               |8|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|

9                                                                |8|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|7|

9                         Table 8.1

____________________
9   [|-]Only the first character of the string is significant (i.e "s"
is ok for "subroutine")

9                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                         8-3

           Lambda and lexpr functions both  compile  into  a
      binary object with a discipline of lambda.  However, a
      compiled lexpr still acts like an interpreted lexpr.

   8.3.  macros

           An important feature of Lisp is  its  ability  to
      manipulate  programs  as  data.   As a result of this,
      most Lisp implementations  have  very  powerful  macro
      facilities.  The Lisp language's macro facility can be
      used to incorporate  popular  features  of  the  other
      languages  into  Lisp.   For  example, there are macro
      packages which allow one to create records  (ala  Pas-
      cal)  and  refer  to  elements of those records by the
      field names.  The _s_t_r_u_c_t package imported from Maclisp
      does  this.   Another  popular  use  for  macros is to
      create more readable control structures  which  expand
      into  _c_o_n_d,  _o_r  and  _a_n_d.  One such example is the If
      macro.  It allows you to write

      (_I_f (_e_q_u_a_l _n_u_m_b _0) _t_h_e_n (_p_r_i_n_t '_z_e_r_o) (_t_e_r_p_r)
       _e_l_s_e_i_f (_e_q_u_a_l _n_u_m_b _1) _t_h_e_n (_p_r_i_n_t '_o_n_e) (_t_e_r_p_r)
       _e_l_s_e (_p_r_i_n_t '|_I _g_i_v_e _u_p|))

      which expands to

      (_c_o_n_d
          ((_e_q_u_a_l _n_u_m_b _0) (_p_r_i_n_t '_z_e_r_o) (_t_e_r_p_r))
          ((_e_q_u_a_l _n_u_m_b _1) (_p_r_i_n_t '_o_n_e) (_t_e_r_p_r))
          (_t (_p_r_i_n_t '|_I _g_i_v_e _u_p|)))

      8.3.1.  macro forms

              A macro is a function  which  accepts  a  Lisp
         expression   as  input  and  returns  another  Lisp
         expression.  The action the macro takes  is  called
         macro expansion.  Here is a simple example:

         -> (_d_e_f _f_i_r_s_t (_m_a_c_r_o (_x) (_c_o_n_s '_c_a_r (_c_d_r _x))))
         first
         -> (_f_i_r_s_t '(_a _b _c))
         a
         -> (_a_p_p_l_y '_f_i_r_s_t '(_f_i_r_s_t '(_a _b _c)))
         (car '(a b c))

         The first input line defines a macro called  _f_i_r_s_t.
         Notice  that the macro has one formal parameter, _x.
         On the second input line, we ask the interpreter to

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                         8-4

         evaluate  (_f_i_r_s_t '(_a _b _c)).   _E_v_a_l  sees that _f_i_r_s_t
         has a function definition  of  type  macro,  so  it
         evaluates  _f_i_r_s_t's definition, passing to _f_i_r_s_t, as
         an argument, the form _e_v_a_l  itself  was  trying  to
         evaluate:  (_f_i_r_s_t '(_a _b _c)).  The _f_i_r_s_t macro chops
         off the car of the argument with _c_d_r, cons'  a  _c_a_r
         at   the   beginning   of   the  list  and  returns
         (_c_a_r '(_a _b _c)), which _e_v_a_l evaluates.  The value  _a
         is returned as the value of (_f_i_r_s_t '(_a _b _c)).  Thus
         whenever _e_v_a_l tries to evaluate a  list  whose  car
         has  a macro definition it ends up doing (at least)
         two operations, the first of which is a call to the
         macro  to  let  it  macro  expand the form, and the
         other is the evaluation of the result of the macro.
         The  result of the macro may be yet another call to
         a macro, so _e_v_a_l may have to do even  more  evalua-
         tions  until it can finally determine the  value of
         an expression.  One way to see  how  a  macro  will
         expand  is to use _a_p_p_l_y as shown on the third input
         line above.

      8.3.2.  defmacro

              The macro _d_e_f_m_a_c_r_o makes it easier  to  define
         macros  because it allows you to name the arguments
         to the macro call.  For example,  suppose  we  find
         ourselves      often      writing     code     like
         (_s_e_t_q _s_t_a_c_k (_c_o_n_s _n_e_w_e_l_t _s_t_a_c_k).  We could define a
         macro  named  _p_u_s_h  to  do this for us.  One way to
         define it is:

         -> (_d_e_f _p_u_s_h
               (_m_a_c_r_o (_x) (_l_i_s_t '_s_e_t_q (_c_a_d_d_r _x) (_l_i_s_t '_c_o_n_s (_c_a_d_r _x) (_c_a_d_d_r _x)))))
         push

         then (_p_u_s_h _n_e_w_e_l_t _s_t_a_c_k) will expand  to  the  form
         mentioned above.  The same macro written using def-
         macro would be:

         -> (_d_e_f_m_a_c_r_o _p_u_s_h (_v_a_l_u_e _s_t_a_c_k)
           (_l_i_s_t '_s_e_t_q ,_s_t_a_c_k (_l_i_s_t '_c_o_n_s ,_v_a_l_u_e ,_s_t_a_c_k)))
         push

         Defmacro allows you to name the  arguments  of  the
         macro  call,  and  makes  the macro definition look
         more like a function definition.

9

9                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                         8-5

      8.3.3.  the backquote character macro

              The default syntax for  FRANZ  LISP  has  four
         characters  with  associated character macros.  One
         is semicolon for  comments.   Two  others  are  the
         backquote and comma which are used by the backquote
         character macro.  The  fourth  is  the  sharp  sign
         macro described in the next section.

              The backquote macro is used  to  create  lists
         where many of the elements are fixed (quoted). This
         makes it very useful  for  creating  macro  defini-
         tions.  In the simplest case, a backquote acts just
         like a single quote:

         ->`(_a _b _c _d _e)
         (a b c d e)

         If a comma precedes an element of a backquoted list
         then that element is evaluated and its value is put
         in the list.

         ->(_s_e_t_q _d '(_x _y _z))
         (x y z)
         ->`(_a _b _c ,_d _e)
         (a b c (x y z) e)

         If a comma followed by an at sign precedes an  ele-
         ment  in  a  backquoted  list, then that element is
         evaluated and spliced into the list with _a_p_p_e_n_d.

         ->`(_a _b _c ,@_d _e)
         (a b c x y z e)

         Once a list begins with a backquote, the commas may
         appear anywhere in the list as this example shows:

         ->`(_a _b (_c _d ,(_c_d_r _d)) (_e _f (_g _h ,@(_c_d_d_r _d) ,@_d)))
         (a b (c d (y z)) (e f (g h z x y z)))

         It is also possible and sometimes  even  useful  to
         use  the backquote macro within itself.  As a final
         demonstration of  the  backquote  macro,  we  shall
         define  the  first  and  push  macros using all the
         power at our disposal: defmacro and  the  backquote
         macro.

         ->(_d_e_f_m_a_c_r_o _f_i_r_s_t (_l_i_s_t) `(_c_a_r ,_l_i_s_t))
         first
         ->(_d_e_f_m_a_c_r_o _p_u_s_h (_v_a_l_u_e _s_t_a_c_k) `(_s_e_t_q ,_s_t_a_c_k (_c_o_n_s ,_v_a_l_u_e ,_s_t_a_c_k)))
         stack

9

9                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                         8-6

      8.3.4.  sharp sign character macro

              The sharp sign macro can perform a  number  of
         different  functions   at read time.  The character
         directly following the sharp sign determines  which
         function  will  be  done,  and  following  Lisp  s-
         expressions may serve as arguments.

         8.3.4.1.  conditional inclusion

            If you plan to run one source file in more  than
            one environment then you may want to some pieces
            of code to be included  or not included  depend-
            ing  on  the  environment.  The  C language uses
            "#ifdef" and "#ifndef"  for  this  purpose,  and
            Lisp  uses  "#+" and "#-".  The environment that
            the   sharp   sign   macro   checks    is    the
            (_s_t_a_t_u_s _f_e_a_t_u_r_e_s) list which is initialized when
            the Lisp system  is  built   and  which  may  be
            altered     by     (_s_s_t_a_t_u_s _f_e_a_t_u_r_e _f_o_o)     and
            (_s_s_t_a_t_u_s _n_o_f_e_a_t_u_r_e _b_a_r) The form  of conditional
            inclusion is
                        _#_+_w_h_e_n _w_h_a_t
            where _w_h_e_n is either a symbol or  an  expression
            involving symbols and the functions _a_n_d, _o_r, and
            _n_o_t.  The meaning is that _w_h_a_t will only be read
            in  if  _w_h_e_n  is true.  A symbol in _w_h_e_n is true
            only if  it  appears  in  the  (_s_t_a_t_u_s _f_e_a_t_u_r_e_s)
            list.

    ____________________________________________________

    ; suppose we want to write a program which references a file
    ; and which can run at ucb, ucsd and cmu where the file naming conventions
    ; are different.
    ;
    -> (_d_e_f_u_n _h_o_w_o_l_d (_n_a_m_e)
          (_t_e_r_p_r)
          (_l_o_a_d #+(_o_r _u_c_b _u_c_s_d) "/_u_s_r/_l_i_b/_l_i_s_p/_a_g_e_s._l"
                 #+_c_m_u "/_u_s_r/_l_i_s_p/_d_o_c/_a_g_e_s._l")
          (_p_a_t_o_m _n_a_m_e)
          (_p_a_t_o_m " _i_s ")
          (_p_r_i_n_t (_c_d_r (_a_s_s_o_c _n_a_m_e _a_g_e_f_i_l_e)))
          (_p_a_t_o_m "_y_e_a_r_s _o_l_d")
          (_t_e_r_p_r))
    ____________________________________________________

The form

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                         8-7

                        _#_-_w_h_e_n _w_h_a_t
is equivalent to
                     _#_+_(_n_o_t _w_h_e_n_) _w_h_a_t

         8.3.4.2.  fixnum character equivalents

            When working with fixnum equivalents of  charac-
            ters,  it  is  often hard to remember the number
            corresponding to a character.  The form
                            _#_/_c
            is equivalent to the  fixnum  representation  of
            character c.

    ____________________________________________________

    ; a function which returns t if the user types y else it returns nil.
    ;
    -> (_d_e_f_u_n _y_e_s_o_r_n_o _n_i_l
          (_p_r_o_g_n (_a_n_s)
                 (_s_e_t_q _a_n_s (_t_y_i))
                 (_c_o_n_d ((_e_q_u_a_l _a_n_s #/_y) _t)
                       (_t _n_i_l))))
    ____________________________________________________

         8.3.4.3.  read time evaluation

            Occasionally you want to express a constant as a
            Lisp  expression,  yet you don't want to pay the
            penalty of evaluating this expression each  time
            it is referenced.  The form
                        _#_._e_x_p_r_e_s_s_i_o_n
            evaluates  the  expression  at  read  time   and
            returns its value.

9

9                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                         8-8

    ____________________________________________________

    ; a function to test if any of bits 1 3 or 12 are set in a fixnum.
    ;
    -> (_d_e_f_u_n _t_e_s_t_i_t (_n_u_m)
          (_c_o_n_d ((_z_e_r_o_p (_b_o_o_l_e _1 _n_u_m #.(+ (_l_s_h _1 _1) (_l_s_h _1 _3) (_l_s_h _1 _1_2))))
                 _n_i_l)
                (_t _t)))
    ____________________________________________________

   8.4.  fclosures

           Fclosures are a type of functional  object.   The
      purpose  is  to  remember the values of some variables
      between invocations of the functional  object  and  to
      protect this data from being inadvertently overwritten
      by other Lisp  functions.   Fortran  programs  usually
      exhibit  this behavior for their variables.  (In fact,
      some versions of Fortran would require  the  variables
      to  be  in COMMON).  Thus it is easy to write a linear
      congruent random number generator in  Fortran,  merely
      by keeping the seed as a variable in the function.  It
      is much more risky to do so in Lisp, since any special
      variable you picked, might be used by some other func-
      tion.  Fclosures are an attempt to provide most of the
      same  functionality  as closures in Lisp Machine Lisp,
      to users of FRANZ LISP.  Fclosures are related to clo-
      sures in this way:
      (fclosure '(a b) 'foo) <==>
              (let ((a a) (b b)) (closure '(a b) 'foo))

      8.4.1.  an example

____________________________________________________________

% lisp
Franz Lisp, Opus 38.60
->(defun code (me count)
  (print (list 'in x))
  (setq x (+ 1 x))
  (cond ((greaterp count 1) (funcall me me (sub1 count))))
  (print (list 'out x)))
code
->(defun tester (object count)
  (funcall object object count) (terpri))

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                         8-9

tester
->(setq x 0)
0
->(setq z (fclosure '(x) 'code))
fclosure[8]
-> (tester z 3)
(in 0)(in 1)(in 2)(out 3)(out 3)(out 3)
nil
->x
0
____________________________________________________________

              The function _f_c_l_o_s_u_r_e  creates  a  new  object
         that  we  will  call  an  fclosure, (although it is
         actually a vector).  The fclosure contains a  func-
         tional  object, and a set of symbols and values for
         the symbols.  In the above  example,  the  fclosure
         functional object is the function code.  The set of
         symbols and values just contains the symbol `x' and
         zero,  the  value  of  `x'  when  the  fclosure was
         created.

         When an fclosure is funcall'ed:

         1)   The Lisp system lambda binds  the  symbols  in
              the fclosure to their values in the fclosure.

         2)   It continues the  funcall  on  the  functional
              object of the fclosure.

         3)   Finally, it un-lambda binds the symbols in the
              fclosure  and  at  the  same  time  stores the
              current values of the symbols in the fclosure.

              Notice that the fclosure is saving  the  value
         of  the  symbol  `x'.   Each  time  a  fclosure  is
         created, new space  is  allocated  for  saving  the
         values  of the symbols. Thus if we execute fclosure
         again, over the same  function,  we  can  have  two
         independent counters:

____________________________________________________________

-> (setq zz (fclosure '(x) 'code))
fclosure[1]
-> (tester zz 2)
(in 0)(in 1)(out 2)(out 2)
-> (tester zz 2)

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                        8-10

(in 2)(in 3)(out 4)(out 4)
-> (tester z 3)
(in 3)(in 4)(in 5)(out 6)(out 6)(out 6)
____________________________________________________________

      8.4.2.  useful functions

              Here are some quick some  summaries  of  func-
         tions  dealing  with  closures.  They are more for-
         mally defined in 2.8.4.  To  recap,  fclosures  are
         made by (_f_c_l_o_s_u_r_e '_l__v_a_r_s '_g__f_u_n_c_o_b_j).  l_vars is a
         list of symbols (not containing nil), g_funcobj  is
         any  object  that can be funcalled.  (Objects which
         can be funcalled, include compiled Lisp  functions,
         lambda  expressions,  symbols,  foreign  functions,
         etc.) In general, if you want a  compiled  function
         to  be closed over a variable, you must declare the
         variable  to  be  special  within   the   function.
         Another example would be:

                     (fclosure '(a b) #'(lambda (x) (plus x a)))

         Here, the #' construction will  make  the  compiler
         compile the lambda expression.

              There are times when you want to  share  vari-
         ables  between  fclosures.  This can be done if the
         fclosures  are  created  at  the  same  time  using
         _f_c_l_o_s_u_r_e-_l_i_s_t.  The function _f_c_l_o_s_u_r_e-_a_l_i_s_t returns
         an assoc list giving the symbols and values in  the
         fclosure.   The  predicate  _f_c_l_o_s_u_r_e_p returns t iff
         its  argument  is  a  fclosure.   Other   functions
         imported  from  Lisp  Machine  Lisp are _s_y_m_e_v_a_l-_i_n-
         _f_c_l_o_s_u_r_e,   _l_e_t-_f_c_l_o_s_e_d,    and    _s_e_t-_i_n-_f_c_l_o_s_u_r_e.
         Lastly,  the function _f_c_l_o_s_u_r_e-_f_u_n_c_t_i_o_n returns the
         function argument.

      8.4.3.  internal structure

              Currently, closures are  implemented  as  vec-
         tors, with property being the symbol fclosure.  The
         functional object is the first entry.  The  remain-
         ing  entries are structures which point to the sym-
         bols and values for the closure, (with a  reference
         count  to  determine  if  a  recursive  closure  is

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                        8-11

         active).

   8.5.  foreign subroutines and functions

           FRANZ LISP has the ability  to  dynamically  load
      object  files  produced by other compilers and to call
      functions defined in those files.  These functions are
      called _f_o_r_e_i_g_n functions.* There are  seven  types  of
      foreign functions.  They are characterized by the type
      of result they  return,  and  by  differences  in  the
      interpretation of their arguments.  They come from two
      families: a group  suited  for  languages  which  pass
      arguments  by  reference  (e.g.  Fortran), and a group
      suited for languages which  pass  arguments  by  value
      (e.g. C).

      There are four types in the first group:

      subroutine
           This does not return anything.  The  Lisp  system
           always returns t after calling a subroutine.

      function
           This returns whatever the function returns.  This
           must  be  a valid Lisp object or it may cause the
           Lisp system to fail.

      integer-function
           This returns an integer  which  the  Lisp  system
           makes into a fixnum and returns.

      real-function
           This returns a double precision real number which
           the Lisp system makes into a flonum and returns.

      There are three types in the second group:

      c-function
           This is like an integer function, except for  its
           different interpretation of arguments.

____________________
9   *This topic is also discussed in Report  PAM-124  of  the
Center  for  Pure  and  Applied  Mathematics,  UCB, entitled
``Parlez-Vous Franz?  An Informal Introduction to  Interfac-
ing Foreign Functions to Franz LISP'', by James R. Larus

9                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                        8-12

      double-c-function
           This is like a real-function.

      vector-c-function
           This is for C functions which return a structure.
           The  first  argument  to such functions must be a
           vector (of type vectori), into which  the  result
           is  stored.  The second Lisp argument becomes the
           first argument to the C function, and so on

      A foreign function is accessed through a binary object
      just like a compiled Lisp function.  The difference is
      that the discipline field of a  binary  object  for  a
      foreign  function is a string whose first character is
      given in the following table:

8                   ____________________________
                    letter         type
8                   ________________________________________________________
                      s         subroutine
8                   ____________________________
                      f          function
8                   ____________________________
                      i      integer-function
8                   ____________________________
                      r       real-function.
8                   ____________________________
                      c         c-function
8                   ____________________________
                      v      vector-c-function
8                   ____________________________
                      d      double-c-function
8                   ____________________________
7                  |7|7|7|7|7|7|7|7|7|7|7|

                          |7|7|7|7|7|7|7|7|7|7|7|

                                              |7|7|7|7|7|7|7|7|7|7|7|

      Two functions  are  provided  for  setting-up  foreign
      functions.   _C_f_a_s_l  loads an object file into the Lisp
      system and sets up one foreign function binary object.
      If there are more than one function in an object file,
      _g_e_t_a_d_d_r_e_s_s can be used to set  up  additional  foreign
      function objects.

           Foreign  functions are  called  just  like  other
      functions,  e.g  (_f_u_n_n_a_m_e _a_r_g_1 _a_r_g_2).  When a function
      in the Fortran group  is  called,  the  arguments  are
      evaluated  and  then  examined.  List, hunk and symbol
      arguments are passed unchanged to  the  foreign  func-
      tion.   Fixnum  and flonum arguments are copied into a
      temporary location and  a  pointer  to  the  value  is
      passed (this is because Fortran uses call by reference
      and it is dangerous to modify the contents of a fixnum
      or  flonum  which  something else might point to).  If
      the argument is an array object, the data field of the
      array  object  is passed to the foreign function (This
      is the easiest way to send large amounts  of  data  to
      and receive large amounts of data from a foreign func-
      tion).  If a binary object is an argument,  the  entry

9                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                        8-13

      field of that object is passed to the foreign function
      (the entry field is the address of a function, so this
      amounts to passing a function as an argument).

           When a function in the C group is called,  fixnum
      and flownum arguments are passed by value.  For almost
      all other arguments, the address is merely provided to
      the  C  routine.   The  only exception arises when you
      want to invoke a C routine which  expects  a  ``struc-
      ture''  argument.  Recall that a (rarely used) feature
      of the C language is the ability to pass structures by
      value.   This  copies  the  structure  onto the stack.
      Since the Franz's nearest equivalent to a C  structure
      is  a  vector, we provide an escape clause to copy the
      contents of an immediate-type vector by value.  If the
      property  field  of  a vectori argument, is the symbol
      "value-structure-argument", then the  binary  data  of
      this immediate-type vector is copied into the argument
      list of the C routine.

           The method a foreign function uses to access  the
      arguments   provided  by  Lisp  is  dependent  on  the
      language  of  the  foreign  function.   The  following
      scripts  demonstrate  how  how  Lisp can interact with
      three languages: C, Pascal and Fortran.  C and  Pascal
      have  pointer  types and the first script shows how to
      use pointers to extract information from Lisp objects.
      There  are  two  functions  defined for each language.
      The first (cfoo in C, pfoo in Pascal)  is  given  four
      arguments,  a  fixnum, a flonum-block array, a hunk of
      at least two fixnums and a list of at least  two  fix-
      nums.   To  demonstrate  that  the values were passed,
      each ?foo function prints its arguments (or  parts  of
      them).   The  ?foo  function  then modifies the second
      element of the flonum-block array and returns a  3  to
      Lisp.   The second function (cmemq in C, pmemq in Pas-
      cal) acts just like the Lisp _m_e_m_q function (except  it
      won't work for fixnums whereas the lisp _m_e_m_q will work
      for small fixnums).  In the script, typed input is  in
      bold,  computer output is in roman and comments are in
      _i_t_a_l_i_c.

____________________________________________________________

_T_h_e_s_e _a_r_e _t_h_e _C _c_o_d_e_d _f_u_n_c_t_i_o_n_s
% cat ch8auxc.c
/* demonstration of c coded foreign integer-function */

/* the following will be used to extract fixnums out of a list of fixnums */
struct listoffixnumscell
{    struct listoffixnumscell *cdr;
     int *fixnum;

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                        8-14

};

struct listcell
{       struct listcell *cdr;
        int car;
};

cfoo(a,b,c,d)
int *a;
double b[];
int *c[];
struct listoffixnumscell *d;
{
    printf("a: %d, b[0]: %f, b[1]: %f0, *a, b[0], b[1]);
    printf(" c (first): %d   c (second): %d0,
               *c[0],*c[1]);
    printf(" ( %d %d ... ) ", *(d->fixnum), *(d->cdr->fixnum));
    b[1] = 3.1415926;
    return(3);
}

struct listcell *
cmemq(element,list)
int element;
struct listcell *list;
{
   for( ; list && element != list->car ;  list = list->cdr);
   return(list);
}

_T_h_e_s_e _a_r_e _t_h_e _P_a_s_c_a_l _c_o_d_e_d _f_u_n_c_t_i_o_n_s
% cat ch8auxp.p
type    pinteger = ^integer;
        realarray = array[0..10] of real;
        pintarray = array[0..10] of pinteger;
        listoffixnumscell = record
                                cdr  : ^listoffixnumscell;
                                fixnum : pinteger;
                            end;
        plistcell = ^listcell;
        listcell = record
                      cdr : plistcell;
                      car : integer;
                   end;

function pfoo ( var a : integer ;
                var b : realarray;
                var c : pintarray;
                var d : listoffixnumscell) : integer;
begin
   writeln(' a:',a, ' b[0]:', b[0], ' b[1]:', b[1]);
   writeln(' c (first):', c[0]^,' c (second):', c[1]^);

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                        8-15

   writeln(' ( ', d.fixnum^, d.cdr^.fixnum^, ' ...) ');
   b[1] := 3.1415926;
   pfoo := 3
end ;

{ the function pmemq looks for the Lisp pointer given as the first argument
  in the list pointed to by the second argument.
  Note that we declare " a : integer " instead of " var a : integer " since
  we are interested in the pointer value instead of what it points to (which
  could be any Lisp object)
}
function pmemq( a : integer; list : plistcell) : plistcell;
begin
 while (list <> nil) and (list^.car <> a) do list := list^.cdr;
 pmemq := list;
end ;

_T_h_e _f_i_l_e_s _a_r_e _c_o_m_p_i_l_e_d
% cc -c ch8auxc.c
1.0u 1.2s 0:15 14% 30+39k 33+20io 147pf+0w
% pc -c ch8auxp.p
3.0u 1.7s 0:37 12% 27+32k 53+32io 143pf+0w

% lisp
Franz Lisp, Opus 38.60
_F_i_r_s_t _t_h_e _f_i_l_e_s _a_r_e _l_o_a_d_e_d _a_n_d _w_e _s_e_t _u_p _o_n_e  _f_o_r_e_i_g_n  _f_u_n_c_-
_t_i_o_n  _b_i_n_a_r_y.  _W_e _h_a_v_e _t_w_o _f_u_n_c_t_i_o_n_s _i_n _e_a_c_h _f_i_l_e _s_o _w_e _m_u_s_t
_c_h_o_o_s_e _o_n_e _t_o _t_e_l_l _c_f_a_s_l _a_b_o_u_t.  _T_h_e _c_h_o_i_c_e _i_s _a_r_b_i_t_r_a_r_y.
-> (cfasl 'ch8auxc.o '_cfoo 'cfoo "integer-function")
/usr/lib/lisp/nld -N -A /usr/local/lisp -T 63000 ch8auxc.o -e _cfoo -o /tmp/Li7055.0  -lc
#63000-"integer-function"
-> (cfasl 'ch8auxp.o '_pfoo 'pfoo "integer-function" "-lpc")
/usr/lib/lisp/nld -N -A /tmp/Li7055.0 -T 63200 ch8auxp.o -e _pfoo -o /tmp/Li7055.1 -lpc -lc
#63200-"integer-function"
_H_e_r_e _w_e _s_e_t _u_p _t_h_e _o_t_h_e_r _f_o_r_e_i_g_n _f_u_n_c_t_i_o_n _b_i_n_a_r_y _o_b_j_e_c_t_s
-> (getaddress '_cmemq 'cmemq "function" '_pmemq 'pmemq "function")
#6306c-"function"
_W_e _w_a_n_t _t_o _c_r_e_a_t_e _a_n_d _i_n_i_t_i_a_l_i_z_e _a_n _a_r_r_a_y  _t_o  _p_a_s_s  _t_o  _t_h_e
_c_f_o_o  _f_u_n_c_t_i_o_n.  _I_n _t_h_i_s _c_a_s_e _w_e _c_r_e_a_t_e _a_n _u_n_n_a_m_e_d _a_r_r_a_y _a_n_d
_s_t_o_r_e _i_t _i_n _t_h_e _v_a_l_u_e _c_e_l_l _o_f _t_e_s_t_a_r_r.  _W_h_e_n  _w_e  _c_r_e_a_t_e  _a_n
_a_r_r_a_y  _t_o  _p_a_s_s  _t_o  _t_h_e  _P_a_s_c_a_l _p_r_o_g_r_a_m _w_e _w_i_l_l _u_s_e _a _n_a_m_e_d
_a_r_r_a_y _j_u_s_t _t_o _d_e_m_o_n_s_t_r_a_t_e _t_h_e _d_i_f_f_e_r_e_n_t _w_a_y _t_h_a_t  _n_a_m_e_d  _a_n_d
_u_n_n_a_m_e_d _a_r_r_a_y_s _a_r_e _c_r_e_a_t_e_d _a_n_d _a_c_c_e_s_s_e_d.
-> (setq testarr (array nil flonum-block 2))
array[2]
-> (store (funcall testarr 0) 1.234)
1.234
-> (store (funcall testarr 1) 5.678)
5.678
-> (cfoo 385 testarr (hunk 10 11 13 14) '(15 16 17))
a: 385, b[0]: 1.234000, b[1]: 5.678000

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                        8-16

 c (first): 10   c (second): 11
 ( 15 16 ... )
 3
_N_o_t_e _t_h_a_t _c_f_o_o _h_a_s _r_e_t_u_r_n_e_d _3 _a_s _i_t _s_h_o_u_l_d.  _I_t _a_l_s_o _h_a_d _t_h_e
_s_i_d_e  _e_f_f_e_c_t  _o_f  _c_h_a_n_g_i_n_g  _t_h_e _s_e_c_o_n_d _v_a_l_u_e _o_f _t_h_e _a_r_r_a_y _t_o
_3._1_4_1_5_9_2_6  _w_h_i_c_h _c_h_e_c_k _n_e_x_t.
-> (funcall testarr 1)
3.1415926

_I_n _p_r_e_p_a_r_a_t_i_o_n _f_o_r _c_a_l_l_i_n_g _p_f_o_o _w_e _c_r_e_a_t_e _a_n _a_r_r_a_y.
-> (array test flonum-block 2)
array[2]
-> (store (test 0) 1.234)
1.234
-> (store (test 1) 5.678)
5.678
-> (pfoo 385 (getd 'test) (hunk 10 11 13 14) '(15 16 17))
 a:       385 b[0]:  1.23400000000000E+00 b[1]:  5.67800000000000E+00
 c (first):        10 c (second):        11
 (         15        16 ...)
3
-> (test 1)
3.1415926

 _N_o_w _t_o _t_e_s_t _o_u_t _t_h_e _m_e_m_q'_s
-> (cmemq 'a '(b c a d e f))
(_a _d _e _f)
-> (pmemq 'e '(a d f g a x))
_n_i_l
____________________________________________________________

           The Fortran example will be much shorter since in
      Fortran  you can't follow pointers as you can in other
      languages.  The Fortran function ffoo is  given  three
      arguments:  a  fixnum, a fixnum-block array and a flo-
      num.  These arguments are printed out to  verify  that
      they  made it and then the first value of the array is
      modified.  The function  returns  a  double  precision
      value  which  is  converted  to  a  flonum by lisp and
      printed.  Note that the entry point  corresponding  to
      the  Fortran function ffoo is _ffoo_ as opposed to the
      C and Pascal convention of preceding the name with  an
      underscore.

____________________________________________________________

% cat ch8auxf.f

                                   Printed: January 31, 1984

Functions, Fclosures, and Macros                        8-17

        double precision function ffoo(a,b,c)
        integer a,b(10)
        double precision c
        print 2,a,b(1),b(2),c
2       format(' a=',i4,', b(1)=',i5,', b(2)=',i5,' c=',f6.4)
        b(1) = 22
        ffoo = 1.23456
        return
        end
% f77 -c ch8auxf.f
ch8auxf.f:
   ffoo:
0.9u 1.8s 0:12 22% 20+22k 54+48io 158pf+0w
% lisp
Franz Lisp, Opus 38.60
-> (cfasl 'ch8auxf.o '_ffoo_ 'ffoo "real-function" "-lF77 -lI77")
/usr/lib/lisp/nld -N -A /usr/local/lisp -T 63000 ch8auxf.o -e _ffoo_
-o /tmp/Li11066.0 -lF77 -lI77 -lc
#6307c-"real-function"

-> (array test fixnum-block 2)
array[2]
-> (store (test 0) 10)
10
-> (store (test 1) 11)
11
-> (ffoo 385 (getd 'test) 5.678)
 a= 385, b(1)=   10, b(2)=   11 c=5.6780
1.234559893608093
-> (test 0)
22

____________________________________________________________

9

9                                   Printed: January 31, 1984


                        CHAPTER  11

              The Joseph Lister Trace Package

     The Joseph Lister[] Trace package is an important  tool
for the interactive debugging of a Lisp program.  It  allows
you  to  examine selected  calls to a function or functions,
and optionally to stop execution  of  the  Lisp  program  to
examine the values of variables.

     The trace package is a set of Lisp programs located  in
the    Lisp   program   library   (usually   in   the   file
/usr/lib/lisp/trace.l).  Although not normally loaded in the
Lisp  system,  the  package will be loaded in when the first
call to _t_r_a_c_e is made.

(trace [ls_arg1 ...])

     WHERE:   the form of the ls_arg_i is described below.

     RETURNS: a list of the  function  sucessfully  modified
              for  tracing.   If  no  arguments are given to
              _t_r_a_c_e, a list of all functions currently being
              traced is returned.

     SIDE EFFECT: The function definitions of the  functions
                  to trace are modified.

The ls_arg_i can have one of the following forms:

  foo - when foo is entered and exited, the  trace  informa-
       tion will be printed.

  (foo break) - when foo is entered  and  exited  the  trace
       information  will  be  printed.  Also, just after the
       trace information for foo is printed upon entry,  you
       will  be put in  a special break loop.  The prompt is
       `T>' and you may type any Lisp  expression,  and  see
       its  value printed.  The _ith argument to the function
       just called can be accessed as (arg _i).  To leave the
       trace   loop,  just  type  ^D  or  (tracereturn)  and
____________________
9   []_L_i_s_t_e_r, _J_o_s_e_p_h     1st  Baron  Lister  of  Lyme  Regis,
1827-1912; English surgeon: introduced antiseptic surgery.

9The Joseph Lister Trace Package                         11-1

The Joseph Lister Trace Package                         11-2

       execution will continue.  Note that ^D will work only
       on UNIX systems.

  (foo if expression) - when foo is entered and the  expres-
       sion evaluates to non-nil, then the trace information
       will be printed for both exit and entry.  If  expres-
       sion evaluates to nil, then no trace information will
       be printed.

  (foo ifnot expression) -  when  foo  is  entered  and  the
       expression  evaluates to nil, then the trace informa-
       tion will be printed for both  entry  and  exit.   If
       both  if and ifnot are specified, then the if expres-
       sion must evaluate to non nil AND the  ifnot  expres-
       sion  must  evaluate to nil for the trace information
       to be printed out.

  (foo evalin expression) - when foo is  entered  and  after
       the  entry  trace  information is printed, expression
       will be evaluated. Exit  trace  information  will  be
       printed when foo exits.

  (foo evalout expression) -  when  foo  is  entered,  entry
       trace  information  will be printed.  When foo exits,
       and before the exit  trace  information  is  printed,
       expression will be evaluated.

  (foo evalinout expression) - this has the same  effect  as
       (trace (foo evalin expression evalout expression)).

  (foo lprint) - this tells _t_r_a_c_e to use the  level  printer
       when  printing  the arguments to and the result of  a
       call to foo.  The level printer prints only  the  top
       levels  of  list structure. Any structure below three
       levels is printed as a &.  This allows you  to  trace
       functions with massive arguments or results.

          The following trace options  permit  one  to  have
     greater control over each action which takes place when
     a function is traced.  These options are only meant  to
     be used by people who need special hooks into the trace
     package.  Most people should skip reading this section.

  (foo traceenter  tefunc)  -  this  tells  _t_r_a_c_e  that  the

                                      Printed: July 27, 1983

The Joseph Lister Trace Package                         11-3

       function  to be called when foo is entered is tefunc.
       tefunc should be a lambda of two arguments, the first
       argument  will  be  bound to the name of the function
       being traced, foo in this case.  The second  argument
       will  be  bound to the list of arguments to which foo
       should be applied.  The function tefunc should  print
       some  sort  of "entering foo" message.  It should not
       apply foo to the arguments,  however.  That  is  done
       later on.

  (foo traceexit txfunc) - this tells _t_r_a_c_e that  the  func-
       tion  to  be  called  when  foo  is exited is txfunc.
       txfunc should be a lambda of two arguments, the first
       argument  will  be  bound to the name of the function
       being traced, foo in this case.  The second  argument
       will  be bound to the result of the call to foo.  The
       function txfunc should print some  sort  of  "exiting
       foo" message.

  (foo evfcn evfunc) - this tells _t_r_a_c_e that the form evfunc
       should  be  evaluated to get the value of foo applied
       to its arguments. This option is a bit different from
       the  other  special options since evfunc will usually
       be an expression, not just the name  of  a  function,
       and  that  expression will be specific to the evalua-
       tion of  function  foo.   The  argument  list  to  be
       applied will be available as T-arglist.

  (foo printargs prfunc) - this tells _t_r_a_c_e to  used  prfunc
       to print the arguments  to be applied to the function
       foo.  prfunc should be a lambda of one argument.  You
       might  want  to use this option if you wanted a print
       function which could  handle  circular  lists.   This
       option  will work only if you do not specify your own
       traceenter function.  Specifying the option lprint is
       just  a simple way of changing the printargs function
       to the level printer.

  (foo printres prfunc) - this tells _t_r_a_c_e to use prfunc  to
       print the result of evaluating foo.  prfunc should be
       a lambda of one argument.  This option will work only
       if  you  do  not specify your own traceexit function.
       Specifying the option lprint changes printres to  the
       level printer.

          You may specify more  than  one  option  for  each
     function traced. For example:

                                      Printed: July 27, 1983

The Joseph Lister Trace Package                         11-4

     (_t_r_a_c_e (_f_o_o _i_f (_e_q _3 (_a_r_g _1)) _b_r_e_a_k _l_p_r_i_n_t) (_b_a_r _e_v_a_l_i_n
     (_p_r_i_n_t _x_y_z_z_y)))

     This tells _t_r_a_c_e to trace two more functions,  foo  and
     bar.   Should  foo be called with the first argument _e_q
     to 3, then the entering foo  message  will  be  printed
     with  the  level  printer.   Next it will enter a trace
     break loop, allowing you to evaluate any  lisp  expres-
     sions.  When you exit the trace break loop, foo will be
     applied to its arguments and the resulting  value  will
     be printed, again using the level printer.  Bar is also
     traced, and each time bar is entered, an  entering  bar
     message  will  be  printed  and then the value of xyzzy
     will be printed.  Next bar will be applied to its argu-
     ments  and  the  result  will  be printed.  If you tell
     _t_r_a_c_e to trace a function which is already  traced,  it
     will  first  _u_n_t_r_a_c_e  it.   Thus if you want to specify
     more than one trace option for a function, you must  do
     it all at once.  The following is _n_o_t equivalent to the
     preceding call to _t_r_a_c_e for foo:

     (_t_r_a_c_e (_f_o_o  _i_f  (_e_q  _3  (_a_r_g  _1)))  (_f_o_o  _b_r_e_a_k)  (_f_o_o
     _l_p_r_i_n_t))

     In this example, only the last option, lprint, will  be
     in effect.

          If the symbol $tracemute is given a non nil value,
     printing  of  the  function name and arguments on entry
     and exit will be surpressed.  This is particularly use-
     ful  if  the  function you are tracing fails after many
     calls to it.  In this case  you  would  tell  _t_r_a_c_e  to
     trace  the function, set $tracemute to t, and begin the
     computation.  When an error occurs  you  can  use  _t_r_a_-
     _c_e_d_u_m_p to print out the current trace frames.

          Generally the trace package has its  own  internal
     names  for  the the lisp functions it uses, so that you
     can feel free to trace system functions like  _c_o_n_d  and
     not worry about adverse interaction with the actions of
     the trace package.  You can trace any type of function:
     lambda,  nlambda,  lexpr  or  macro whether compiled or
     interpreted and you can  even  trace  array  references
     (however  you  should  not attempt to store in an array
     which has been traced).

          When tracing compiled code keep in mind that  many
     function  calls  are  translated  directly  to  machine
     language  or other equivalent  function calls.  A  full
     list of open coded functions is listed at the beginning
     of  the  liszt  compiler  source.   _T_r_a_c_e  will  do   a
     (_s_s_t_a_t_u_s _t_r_a_n_s_l_i_n_k _n_i_l)  to  insure that the new traced
     definitions it defines are called instead  of  the  old

                                      Printed: July 27, 1983

The Joseph Lister Trace Package                         11-5

     untraced  ones.  You may notice that compiled code will
     run slower after this is done.

(traceargs s_func [x_level])

     WHERE:   if x_level is missing it is assumed to be 1.

     RETURNS: the arguments to the x_level_t_h call to  traced
              function s_func are returned.

(tracedump)

     SIDE EFFECT: the  currently  active  trace  frames  are
                  printed  on  the terminal.  returns a list
                  of functions untraced.

(untrace [s_arg1 ...])

     RETURNS: a list of the functions which were untraced.

     NOTE: if no arguments  are  given,  all  functions  are
           untraced.

     SIDE EFFECT: the old function definitions of all traced
                  functions  are restored except in the case
                  where it appears that the current  defini-
                  tion  of  a  function  was  not created by
                  trace.

9

9                                      Printed: July 27, 1983


# Function definitions

#' Crea un dibujo de un gato en ascii
#'
#' @param numeroDeGatos el numero de gatos a imprimir
#'
#' @return none
#' @export
#'
#' @examples
#'
#' crearGato(10)
#'
crearGato <- function(numeroDeGatos){

for(i in 1:numeroDeGatos){
  cat("  /\\___/\\
  |     |
_  *   *  _
-   /_\   -
    ---")
  }

}

#' Calculates the Shannon Diversity Index using ln base e
#'
#' @param species vector of abundances of species
#'
#' @return the Shannon Diversity Index
#'
#' @export
#'
#' @examples
#'
#' shannon(datosPruebaShannon)
#'
shannon <- function(species)
{
  species <- species[species>0]
  species <- species/sum(species)
  H <- -sum(species* log(species))
  return(H)
}

#' Fix the problems of chlorophyll-a data set
#'
#' @param chla data.frame with original data
#'
#' @return data.frame with fixed data
#' @export
#
#' @examples
#'
#' filename <- system.file("extdata", "Clorofila.txt", package = "PaqueGato")
#'
#' chla <- read.delim(filename)
#'
#' fixClorophylData(filename)
#'
fixClorophylData <- function(chla)
{
  actual_year <- chla$year[1]
  chla$Date <- as.Date("1900-01-01")

  for(i in 1:nrow(chla))
  {
    if( is.na(chla$Year[i]))
        chla$Year[i] <- actual_year
    else
        actual_year <- chla$Year[i]

    fecha <- lubridate::ymd(paste(chla$Year[i],chla$Month[i], 1))
    if( is.na(fecha)){
      if(chla$Month[i]=="Mar")
        fecha <- lubridate::ymd(paste(chla$Year[i],3, 1))
      else {
        fecha <- lubridate::dmy(chla$Month[i])

        if(is.na(fecha)) {
          fecha <- lubridate::mdy(chla$Month[i])

          if(is.na(fecha)) {
            temp <- strsplit(chla$Month[i]," ")[[1]][3]
            fecha <- lubridate::dmy(temp)
          }
        }
      }
    }
    chla$Date[i] <- fecha

  }

  chla$IntegE1 <- abs(chla$IntegE1)
  chla$IntegE2 <- abs(as.numeric(chla$IntegE2))

  return(chla)
}

#' Read ecological networks in CSV format as edge list or adyacency matrix
#'
#' @param fileName Filename of the csv formated network
#'
#' @return an igraph object
#' @export
#'
#' @examples readEcoNetwork("econetwork.csv")
readEcoNetwork <- function(fileName){

  g <- lapply(fileName, function(fname){

    web <- read.csv(fname,  header = T,check.names = F)

    if( ncol(web)==2 ){
      web <- web[,c(2,1)]

      g <- graph_from_data_frame(web)

    } else {
      if( (ncol(web)-1) == nrow(web)  ) {                   # The adjacency matrix must be square
        g <- graph_from_adjacency_matrix(as.matrix(web[,2:ncol(web)]))

      } else {
        g <- NULL
        warning("Invalid file format: ",fileName)
      }
    }

  })
  return(g)
}


#' cpuvec class
#'
#' Storage and methods for CPU vector data.
#'
#' @details
#' Data is held in an external pointer.
#'
#' @rdname cpuvec-class
#' @name cpuvec-class
cpuvecR6 = R6::R6Class("cpuvec",
  public = list(
    #' @details
    #' Class initializer. See also \code{?cpuvec}.
    #' @param size The length of the vector.
    #' @param type Storage type for the vector. Should be one of 'int', 'float', or 'double'.
    #' @useDynLib fmlr R_cpuvec_init
    initialize = function(size=0, type="double")
    {
      type = match.arg(tolower(type), TYPES_STR)

      size = as.integer(size)

      private$type_str = type
      private$type = type_str2int(type)
      private$x_ptr = .Call(R_cpuvec_init, private$type, size)
    },

    #' @details
    #' Change the length of the vector object.
    #' @param size The new length.
    #' @useDynLib fmlr R_cpuvec_resize
    resize = function(size)
    {
      size = as.integer(size)
      .Call(R_cpuvec_resize, private$type, private$x_ptr, size)
      invisible(self)
    },

    #' @details
    #' Set the data in the cpuvec object to point to the array in 'data'. See
    #' also \code{?as_cpuvec}.
    #' @param data R vector.
    #' @useDynLib fmlr R_cpuvec_inherit
    inherit = function(data)
    {
      if (!is.vector(data) && !float::is.float(data))
        stop("'data' must be a vector")

      if (float::is.float(data) && private$type == TYPE_FLOAT)
      {
        type = TYPE_FLOAT
        rdata = data@Data
      }
      else if (is.integer(data) && private$type == TYPE_INT)
      {
        type = TYPE_INT
        rdata = data
      }
      else if (is.double(data) && private$type == TYPE_DOUBLE)
      {
        type = TYPE_DOUBLE
        rdata = data
      }
      else
        stop("can not mix fundamental types with inherit()")

      .Call(R_cpuvec_inherit, type, private$x_ptr, rdata)
      invisible(self)
    },

    #' @details
    #' Duplicate the vector in a deep copy.
    #' @useDynLib fmlr R_cpuvec_dupe
    dupe = function()
    {
      ret_ptr = .Call(R_cpuvec_dupe, private$type, private$x_ptr)

      tmp = private$x_ptr
      private$x_ptr = ret_ptr
      ret = self$clone()
      private$x_ptr = tmp

      ret
    },

    #' @details
    #' Print one-line information about the vector.
    #' @useDynLib fmlr R_cpuvec_info
    info = function()
    {
      .Call(R_cpuvec_info, private$type, private$x_ptr)
      invisible(self)
    },

    #' @details
    #' Print the data.
    #' @param ndigits Number of decimal digits to print.
    #' @useDynLib fmlr R_cpuvec_print
    print = function(ndigits=4)
    {
      ndigits = min(as.integer(ndigits), 15L)

      .Call(R_cpuvec_print, private$type, private$x_ptr, ndigits)
      invisible(self)
    },

    #' @details
    #' Fill all entries with zero.
    #' @useDynLib fmlr R_cpuvec_fill_zero
    fill_zero = function()
    {
      .Call(R_cpuvec_fill_zero, private$type, private$x_ptr)
      invisible(self)
    },

    #' @details
    #' Fill all entries with supplied value.
    #' @param v Value to set all entries to.
    #' @useDynLib fmlr R_cpuvec_fill_val
    fill_val = function(v)
    {
      v = as.double(v)

      .Call(R_cpuvec_fill_val, private$type, private$x_ptr, v)
      invisible(self)
    },

    #' @details
    #' Fill the vector (column-wise) with linearly-spaced values.
    #' @param start,stop Beginning/end of the linear spacing.
    #' @useDynLib fmlr R_cpuvec_fill_linspace
    fill_linspace = function(start, stop)
    {
      if ((missing(start) && !missing(stop)) || (!missing(start) && missing(stop)))
        stop("must supply both 'start' and 'stop', or neither")

      if (!missing(start))
        start = check_is_number(start)
      else
        start = NULL
      if (!missing(stop))
        stop = check_is_number(stop)
      else
        stop = NULL

      .Call(R_cpuvec_fill_linspace, private$type, private$x_ptr, start, stop)
      invisible(self)
    },

    #' @details
    #' Scale all entries by the supplied value.
    #' @param s Value to scale all entries by.
    #' @useDynLib fmlr R_cpuvec_scale
    scale = function(s)
    {
      s = as.double(s)

      .Call(R_cpuvec_scale, private$type, private$x_ptr, s)
      invisible(self)
    },

    #' @details
    #' Exponentiate all entries by the supplied value.
    #' @param p Value to raise all entries to.
    #' @useDynLib fmlr R_cpuvec_pow
    pow = function(p)
    {
      s = as.double(s)

      .Call(R_cpuvec_pow, private$type, private$x_ptr, p)
      invisible(self)
    },

    #' @details
    #' Reverse rows.
    #' @useDynLib fmlr R_cpuvec_rev
    rev = function()
    {
      .Call(R_cpuvec_rev, private$type, private$x_ptr)
      invisible(self)
    },

    #' @details
    #' Sum the vector.
    #' @return Returns the sum.
    #' @useDynLib fmlr R_cpuvec_sum
    sum = function()
    {
      .Call(R_cpuvec_sum, private$type, private$x_ptr)
    },

    #' @details
    #' Finds the minimum value of the vector.
    #' @return Returns the min.
    #' @useDynLib fmlr R_cpuvec_min
    min = function()
    {
      .Call(R_cpuvec_min, private$type, private$x_ptr)
    },

    #' @details
    #' Finds the maximum value of the vector.
    #' @return Returns the max.
    #' @useDynLib fmlr R_cpuvec_max
    max = function()
    {
      .Call(R_cpuvec_max, private$type, private$x_ptr)
    },

    #' @details
    #' Get element from the vector.
    #' @param i Index (0-based).
    #' @useDynLib fmlr R_cpuvec_get
    get = function(i)
    {
      i = check_is_natnum(i)
      .Call(R_cpuvec_get, private$type, private$x_ptr, i)
    },

    #' @details
    #' Set element of the vector.
    #' @param i Index (0-based).
    #' @param v Value.
    #' @useDynLib fmlr R_cpuvec_set
    set = function(i, v)
    {
      i = check_is_natnum(i)
      v = check_is_number(v)
      .Call(R_cpuvec_set, private$type, private$x_ptr, i, v)
      invisible(self)
    },

    #' @details
    #' Returns length of the vector.
    #' @useDynLib fmlr R_cpuvec_size
    size = function() .Call(R_cpuvec_size, private$type, private$x_ptr),

    #' @details
    #' Returns the external pointer data. For developers only.
    data_ptr = function() private$x_ptr,

    #' @details
    #' Returns the integer code for the underlying storage type. For developers only.
    get_type = function() private$type,

    #' @details
    #' Returns the string code for the underlying storage type. For developers only.
    get_type_str = function() private$type_str,

    #' @details
    #' Returns the integer code the class type, in this case CLASS_VEC.
    get_class = function() CLASS_VEC,

    #' @details
    #' Returns an R vector containing a copy of the class data.
    #' @useDynLib fmlr R_cpuvec_to_robj
    to_robj = function()
    {
      ret = .Call(R_cpuvec_to_robj, private$type, private$x_ptr)
      if (private$type == TYPE_FLOAT)
        ret = float::float32(ret)

      ret
    },

    #' @details
    #' Copies the values of the input to the class data. See also \code{?as_cpuvec}.
    #' @param robj R vector.
    #' @useDynLib fmlr R_cpuvec_from_robj
    from_robj = function(robj)
    {
      if (!is.vector(robj) && !float::is.float(robj))
        stop("'robj' must be a vector")

      if (float::is.float(robj))
      {
        robj_type = TYPE_FLOAT
        rdata = robj@Data
      }
      else if (is.integer(robj))
      {
        robj_type = TYPE_INT
        rdata = robj
      }
      else if (is.double(robj))
      {
        robj_type = TYPE_DOUBLE
        rdata = robj
      }
      else
        stop("bad fundamental type")

      .Call(R_cpuvec_from_robj, private$type, private$x_ptr, robj_type, rdata)
      invisible(self)
    }
  ),

  private = list(
    x_ptr = NULL,
    type = -1L,
    type_str = ""
  )
)

#' cpuvec
#'
#' Constructor for cpuvec objects.
#'
#' @details
#' Data is held in an external pointer.
#'
#' @param size Length of the vector.
#' @param type Storage type for the vector. Should be one of 'int', 'float', or 'double'.
#' @return A cpuvec class object.
#'
#' @seealso \code{\link{cpuvec-class}}
#'
#' @export
cpuvec = function(size=0, type="double")
{
  cpuvecR6$new(size=size, type=type)
}

#' as_cpuvec
#'
#' Convert an R vector to a cpumat object.
#'
#' @param x R vector.
#' @param copy Should the R data be copied? If \code{FALSE}, be careful!
#' @return A cpuvec object.
#'
#' @export
as_cpuvec = function(x, copy=TRUE)
{
  x_type = type_robj2str(x)
  ret = cpuvec(type=x_type)

  if (isTRUE(copy))
    ret$from_robj(x)
  else
    ret$inherit(x)

  ret
}


subroutine pred(kpr,i,j,nadj,madj,ntot,nerror)

# Find the predecessor of j in the adjacency list of i.
# Called by initad, trifnd, swap, dirseg, dirout.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj)

nerror = -1

n = nadj(i,0)

# If the adjacency list of i is empty, then clearly j has no predecessor
# in this adjacency list. Something's wrong; stop.
if(n==0) {
	nerror = 5
	return
}

# The adjacency list of i is non-empty; search through it until j is found;
# subtract 1 from the location of j, and find the contents of this new location
do k = 1,n {
        if(j==nadj(i,k)) {
                km = k-1
                if(km<1) km = n         # Take km modulo n. (The adjacency list
                kpr = nadj(i,km)        # is circular.)
                return
        }
}

# The adjacency list for i doesn't contain j.  Something's wrong; stop.
nerror = 6
return
end