cdksjava.r

化学图形处理软件

#############################################
# Register the fit/predict converter funcs
#############################################
setJavaFunctionConverter(lmFitConverter, function(x,...){inherits(x,'lm')},
                          description='lm fit object to Java',
                          fromJava=F)
setJavaFunctionConverter(lmPredictConverter, function(x,...){inherits(x,'lmregprediction')},
                          description='lm predict object to Java',
                          fromJava=F)
setJavaFunctionConverter(lmSummaryConverter, function(x,...){inherits(x,'summary.lm')},
                          description='lm summary object to Java',
                          fromJava=F)
setJavaFunctionConverter(cnnClassFitConverter, function(x,...){inherits(x,'nnet.formula')},
                          description='cnn (nnet) classification fit object to Java',
                          fromJava=F)
setJavaFunctionConverter(cnnSummaryConverter, function(x,...){inherits(x,'summary.nnet')},
                          description='cnn (nnet) summary object to Java',
                          fromJava=F)
setJavaFunctionConverter(cnnFitConverter, function(x,...){inherits(x,'nnet')},
                          description='cnn (nnet) fit object to Java',
                          fromJava=F)
setJavaFunctionConverter(cnnClassPredictConverter, function(x,...){inherits(x,'cnnclsprediction')},
                          description='cnn (nnet) classification predict object to Java',
                          fromJava=F)
setJavaFunctionConverter(cnnPredictConverter, function(x,...){inherits(x,'cnnregprediction')},
                          description='cnn (nnet) predict object to Java',
                          fromJava=F)
setJavaFunctionConverter(plsFitConverter, function(x,...){inherits(x,'mvr')},
                          description='pls/pcr fit object to Java',
                          fromJava=F)
setJavaFunctionConverter(plsPredictConverter, function(x,...){inherits(x,'plsregressionprediction')},
                          description='pls/pcr predict object to Java',
                          fromJava=F)
                          
buildLM <- function(modelname, params) {
    # params is a java.util.HashMap containing the parameters
    # we need to extract them and add them to this environment
    paramlist <- hashmap.to.list(params)
    attach(paramlist)

    # x will come in as a double[][]
    x <- matrix(unlist(x), nrow=length(x), byrow=TRUE)

    # assumes y ~ all columns of x
    d <- data.frame(y=y,x)
    assign(modelname, lm(y~., d, weights=weights), pos=1)
    detach(paramlist)
    get(modelname)
}

predictLM <- function( modelname, params) {
    # params is a java.util.HashMap containing the parameters
    # we need to extract them and add them to this environment
    paramlist <- hashmap.to.list(params)
    attach(paramlist)

    newx <- data.frame( matrix(unlist(newdata), nrow=length(newdata), byrow=TRUE) )
    names(newx) <- names(get(modelname)$coef)[-1]
    if (interval == '' || !(interval %in% c('confidence','prediction')) ) { 
        interval = 'confidence'
    } 
    preds <- predict( get(modelname), newx, se.fit = TRUE, interval=interval);
    class(preds) <- 'lmregprediction'

    detach(paramlist)
    preds
}

buildCNN <-  function(modelname, params) {
    paramlist <- hashmap.to.list(params)
    attach(paramlist)

    x <- matrix(unlist(x), nrow=length(x), byrow=TRUE)
    y <- matrix(unlist(y), nrow=length(y), byrow=TRUE)
    if (nrow(x) != nrow(y)) { 
        stop('The number of observations in x & y dont match') 
    }

    ninput <- ncol(x)
    nhidden <- size
    noutput <- ncol(y)
    nwt <- (ninput*nhidden) + (nhidden*noutput) + nhidden + noutput
    
    if (class(weights) == 'logical' && !weights) weights <- rep(1, nrow(y))
    if (class(subset) == 'logical' && !subset) subset <- 1:nrow(y)
    if (class(Wts) == 'logical' && !Wts) { Wts <- runif(nwt) }
    if (class(mask) == 'logical' && !mask) { mask <- rep(TRUE, nwt) }

    assign(modelname, 
    nnet(x,y,weights=weights,size=size,Wts=Wts,mask=mask,linout=linout,
    entropy=entropy,softmax=softmax,censored=censored,skip=skip,rang=rang,
    decay=decay,maxit=maxit,Hess=Hess,trace=trace,MaxNWts=MaxNWts,
    abstol=abstol,reltol=reltol), pos=1)

    detach(paramlist)
    get(modelname)
}


buildCNNClass <- function(modelname, params) {
    paramlist <- hashmap.to.list(params)
    attach(paramlist)

    x <- matrix(unlist(x), nrow=length(x), byrow=TRUE)
    y <- factor(unlist(y)) # y will come in as a single vector
    if (nrow(x) != length(y)) { stop('The number of observations in x & y dont match') }

    ninput <- ncol(x)
    nhidden <- size
    if (length(levels(y)) == 2) noutput <- 1
    else noutput = length(levels(y))

    nwt <- (ninput*nhidden) + (nhidden*noutput) + nhidden + noutput
    if (class(weights) == 'logical' && !weights) weights <- rep(1, length(y))
    if (class(subset) == 'logical' && !subset) subset <- 1:length(y)
    if (class(Wts) == 'logical' && !Wts) { Wts <- runif(nwt) }
    if (class(mask) == 'logical' && !mask) { mask <- rep(TRUE, nwt) }
    

    assign(modelname, 
    nnet(y~., data=data.frame(y=y,x=x),weights=weights,size=size,Wts=Wts,mask=mask,linout=linout,
    softmax=softmax,censored=censored,skip=skip,rang=rang,
    decay=decay,maxit=maxit,Hess=Hess,trace=trace,MaxNWts=MaxNWts,
    abstol=abstol,reltol=reltol), pos=1)

    detach(paramlist)
    get(modelname)
}

predictCNN <- function(modelname, params) {
    # Since buildCNN should have been called before this
    # we dont bother loading the nnet library
    paramlist <- hashmap.to.list(params)
    attach(paramlist)

    newx <- data.frame( matrix(unlist(newdata), nrow=length(newdata), byrow=TRUE) )
    names(newx) <- get(modelname)$coefnames
    if (type == '' || !(type %in% c('raw','class')) ) { 
        type = 'raw'
    } 


    preds <- predict( get(modelname), newdata=newx, type=type);
    class(preds) <- 'cnnregprediction'

    detach(paramlist)
    preds
}
predictCNNClass <- function(modelname, params) {
    # Since buildCNNClass should have been called before this
    # we dont bother loading the nnet library
    paramlist <- hashmap.to.list(params)
    attach(paramlist)

    newx <- data.frame( matrix(unlist(newdata), nrow=length(newdata), byrow=TRUE) )
    names(newx) <- get(modelname)$coefnames
    if (type == '' || !(type %in% c('raw','class')) ) { 
        type = 'raw'
    } 

    preds <- predict( get(modelname), newdata=newx, type=type);
    class(preds) <- 'cnnclsprediction'
    detach(paramlist)
    preds
}
    
buildPLS <- function(modelname, params) {
    library(pls.pcr)
    paramlist <- hasmap.to.list(params)
    attach(paramlist)
    
    x <- matrix(unlist(x), nrow=length(x), byrow=TRUE)
    y <- matrix(unlist(y), nrow=length(y), byrow=TRUE)
    if (nrow(x) != nrow(y)) { stop('The number of observations in x & y dont match') }

    if (!ncomp) {
        ncomp <- 1:ncol(x)
    } else {
        ncomp <- unlist(ncomp)
    }

    if (!(method %in% c('PCR','SIMPLS','kernelPLS'))) {
        stop('Invalid methopd specification')
    }
    if (!(validation %in% c('none','CV'))) {
        stop('Invalid validation sepcification')
    }
    
    if (niter == 0 && validation == 'CV') {
        niter = nrow(y)
    }
    

    # We should do this since when both grpsize and niter are specified niter
    # is used. So if grpsize comes in as 0 (which will be the default setting)
    # we specify only niter and if not zero we use grpsize and ignore niter
    if (grpsize != 0) {
        assign(modelname,
        pls(x=x,y=y,ncomp=ncomp,method=method,validation=validation,grpsize=grpsize),
        pos=1)
    } else {
        assign(modelname,
        pls(x=x,y=y,ncomp=ncomp,method=method,validation=validation,niter=niter),
        pos=1)
    }
    detach(paramlist)
    get(modelname)
}
predictPLS <- function(modelname, params) {
    paramlist <- hashmap.to.list(params)
    attach(paramlist)
    
    newX <- matrix(unlist(newX), nrow=length(x), byrow=TRUE)
    model <- get(modelname)
    if (ncol(newX) != model$nvar) {
        stop('The number of independent variables in the new data does not match that specified during building')
    }
    if (nlv == FALSE) {
        preds <- predict(model, newX)
    } else {
        preds <- predict(model, newX, nlv)
    }
    class(preds) <- 'plsregressionprediction'
    preds
}