R/stoploss.R

In stops: Structure Optimized Proximity Scaling

# Idea for stops function allow an arbitrary number of indices in a weighted multi-objective optimization way; for this use stoplose
# write stops_foo where foo is the MDS model of interest
# TODO: also do this with a pareto approach    
#'  Calculate the weighted multiobjective loss function used in STOPS
#'
#' @param obj object returned inside a stop_* function. Uses the stress.m slot for getting the stress. 
#' @param stressweight weight to be used for the fit measure; defaults to 1
#' @param structures which c-structuredness indices to be included in the loss
#' @param strucweight the weights of the structuredness indices; defaults to -1/#number of structures
#' @param strucpars a list of parameters to be passed to the c-structuredness indices in the same order as the values in structures. If the index has no parameters or you want to use the defaults, supply NULL. (alternatively a named list that has the structure name as the element name).
#' @param stoptype what type of weighted combination should be used? Can be 'additive' or 'multiplicative'.
#' @param verbose verbose output
#'
#' @import cordillera
#'
#'
#' @return a list with calculated stoploss ($stoploss), structuredness indices ($strucinidices) and hyperparameters ($parameters and $theta) 
#' 
#' @export
stoploss<- function(obj,stressweight=1,structures=c("cclusteredness","clinearity","cdependence","cmanifoldness","cassociation","cnonmonotonicity","cfunctionality","ccomplexity","cfaithfulness","cregularity","chierarchy","cconvexity","cstriatedness","coutlying","cskinniness","csparsity","cstringiness","cclumpiness","cinequality"),strucweight=rep(-1/length(structures),length(structures)),strucpars,stoptype=c("additive","multiplicative"),verbose=0)
    {
        if(missing(strucpars)) strucpars <- vector("list", length(structures))
        stressi <- obj$stress.m #we use stress.m everytime
        pars <- obj$pars
        confs <- obj$conf 
        if("cclusteredness"%in%structures)
            {
              indst <- which(structures=="cclusteredness")  
              cclusteredness <- do.call(cordillera::cordillera,c(list(confs),strucpars[[indst]]))$normed
            }
         if("cregularity"%in%structures)
            {
              indst <- which(structures=="cregularity")  
              cregularity <- do.call(stops::c_regularity,c(list(confs),strucpars[[indst]]))
            }                          
        if("clinearity"%in%structures)
            {
               indst <- which(structures=="clinearity")
               clinearity <- do.call(stops::c_linearity,list(confs))
           }
        if("cdependence"%in%structures)
            {
               indst <- which(structures=="cdependence")
               cdependence <- do.call(stops::c_dependence,c(list(confs),strucpars[[indst]])) 
           }
        if("cmanifoldness"%in%structures)
            {
               indst <- which(structures=="cmanifoldness")
               cmanifoldness <- do.call(stops::c_manifoldness,c(list(confs)))
           }
        if("cassociation"%in%structures)
            {
               indst <- which(structures=="cassociation")
               cassociation <- do.call(stops::c_association,c(list(confs),strucpars[[indst]]))
           }
        if("cnonmonotonicity"%in%structures)
            {
               indst <- which(structures=="cnonmonotonicity")
               cnonmonotonicity <- do.call(stops::c_nonmonotonicity,c(list(confs),strucpars[[indst]]))
           }
        if("cfunctionality"%in%structures)
            {
               indst <- which(structures=="cfunctionality")
               cfunctionality <- do.call(stops::c_functionality,c(list(confs),strucpars[[indst]])) 
           }
         if("ccomplexity"%in%structures)
            {
               indst <- which(structures=="ccomplexity")
               ccomplexity <- do.call(stops::c_complexity,c(list(confs),strucpars[[indst]])) 
           }
        if("cfaithfulness"%in%structures)
            {
               indst <- which(structures=="cfaithfulness")
               cfaithfulness <- do.call(stops::c_faithfulness,c(list(confs),strucpars[[indst]]))$mda 
            }
         if("chierarchy"%in%structures)
            {
               indst <- which(structures=="chierarchy")
               chierarchy <- do.call(stops::c_hierarchy,c(list(confs),strucpars[[indst]]))
            }
         if("coutlying"%in%structures)
            {
               indst <- which(structures=="coutlying")
               coutlying <- do.call(stops::c_outlying,c(list(confs),strucpars[[indst]]))
            }
         if("cconvexity"%in%structures)
            {
               indst <- which(structures=="cconvexity")
               cconvexity <- do.call(stops::c_convexity,c(list(confs),strucpars[[indst]]))
            }
         if("cskinniness"%in%structures)
            {
               indst <- which(structures=="cskinniness")
               cskinniness <- do.call(stops::c_skinniness,c(list(confs),strucpars[[indst]])) 
            }
         if("cstringiness"%in%structures)
            {
               indst <- which(structures=="cstringiness")
               cstringiness <- do.call(stops::c_stringiness,c(list(confs),strucpars[[indst]])) 
            }
         if("csparsity"%in%structures)
            {
               indst <- which(structures=="csparsity")
               csparsity <- do.call(stops::c_sparsity,c(list(confs),strucpars[[indst]])) 
            }
         if("cclumpiness"%in%structures)
            {
               indst <- which(structures=="cclumpiness")
               cclumpiness <- do.call(stops::c_clumpiness,c(list(confs),strucpars[[indst]])) 
            }
         if("cstriatedness"%in%structures)
            {
               indst <- which(structures=="cstriatedness")
               cstriatedness <- do.call(stops::c_striatedness,c(list(confs),strucpars[[indst]]))
            }
        if("cinequality"%in%structures)
            {
               indst <- which(structures=="cinequality")
               cinequality <- do.call(stops::c_inequality,c(list(confs),strucpars[[indst]]))
            }
         if("cshepardness"%in%structures)
            {
              #indst <- which(structures=="cshepardness")
              cshepardness <- do.call(stops::c_shepardness,list(obj))
           }
        ##TODO add more structures
        struc <- unlist(mget(structures))
        ic <- stressi*stressweight + sum(struc*strucweight) 
        if (stoptype =="multiplicative") ic <- exp(stressweight*log(stressi) + sum(strucweight*log(struc))) #is this what we want? stress/structure or do we want stress - prod(structure)
        if(verbose>0) cat("stoploss =",ic,"mdsloss =",stressi,"structuredness =",struc,"parameters =",pars,"\n")
        #return the full combi of stress and indices or only the aggregated scalars; for aSTOPS and mSTOPS we want the latter but for a Pareto approach we want the first; get rid of the sums in ic if the first is wanted  
        out <- list(stoploss=ic,strucindices=struc,parameters=pars,theta=pars)
        out
    }