diff --git a/Data/SVM.hs b/Data/SVM.hs --- a/Data/SVM.hs +++ b/Data/SVM.hs @@ -1,3 +1,6 @@ +{-| +This module provides a safe bindings to libsvm functions and structures with implicit memory handling. +-} module Data.SVM ( Vector , Problem @@ -12,51 +15,60 @@ , loadModel , saveModel , predict + , withPrintFn + , CSvmPrintFn ) where --- TODO limitare l'export --- TODO verificare l'import - --- import Control.Arrow ((***)) import Control.Exception import Control.Monad (liftM, when) import Data.IntMap (IntMap, toList) import qualified Data.IntMap as M import Data.SVM.Raw (CSvmModel, CSvmNode (..), CSvmParameter, - CSvmProblem (..), + CSvmPrintFn, CSvmProblem (..), c_clone_model_support_vectors, c_svm_check_parameter, c_svm_cross_validation, c_svm_destroy_model, c_svm_load_model, c_svm_predict, c_svm_save_model, - c_svm_train, defaultCParam) + c_svm_set_print_string_function, + c_svm_train, createSvmPrintFnPtr, + defaultCParam) import qualified Data.SVM.Raw as R import Foreign.C.String import Foreign.ForeignPtr import Foreign.Marshal.Alloc (alloca, free, malloc) import Foreign.Marshal.Array -import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Ptr (Ptr, freeHaskellFunPtr, nullPtr) import Foreign.Storable (peek, poke) +-- |Vector type provides a sparse implementation of vector. It uses IntMap as underlying implementation. type Vector = IntMap Double + +-- |SVM problem is a list of maps from training vectors to 1.0 or -1.0 type Problem = [(Double, Vector)] + +-- |'Model' is a wrapper over foreign pointer to 'CSvmModel' newtype Model = Model (ForeignPtr CSvmModel) -data KernelType = Linear - | RBF { gamma :: Double } - | Sigmoid { gamma :: Double, coef0 :: Double } - | Poly { gamma :: Double, coef0 :: Double, degree :: Int} +-- |Kernel function for SVM algorithm. +data KernelType = Linear -- ^Linear kernel function, i.e. dot product + | RBF { gamma :: Double } -- ^Gaussian radial basis function with parameter 'gamma' + | Sigmoid { gamma :: Double, coef0 :: Double } -- ^Sigmoid kernel function + | Poly { gamma :: Double, coef0 :: Double, degree :: Int} -- ^Inhomogeneous polynomial function -data Algorithm = CSvc { c :: Double } - | NuSvc { nu :: Double } - | NuSvr { nu :: Double, c :: Double } - | EpsilonSvr { epsilon :: Double, c :: Double } - | OneClassSvm { nu :: Double } +-- |SVM Algorithm with parameters +data Algorithm = CSvc { c :: Double } -- ^c-SVC algorithm + | NuSvc { nu :: Double } -- ^nu-SVC algorithm + | NuSvr { nu :: Double, c :: Double } -- ^nu-SVR algorithm + | EpsilonSvr { epsilon :: Double, c :: Double } -- ^eps-SVR algorithm + | OneClassSvm { nu :: Double } -- ^One class SVM +-- |Extra parameters of SVM implementation data ExtraParam = ExtraParam {cacheSize :: Double, shrinking :: Int, probability :: Int} +-- |Default extra parameters of SVM implamentation defaultExtra :: ExtraParam defaultExtra = ExtraParam {cacheSize = 1000, shrinking = 1, probability = 0} @@ -146,6 +158,7 @@ -- +-- |Like 'train' but with extra parameters train' :: ExtraParam -> Algorithm -> KernelType -> Problem -> IO Model train' extra algo kern prob = withProblem prob $ \probPtr -> @@ -162,6 +175,7 @@ train :: Algorithm -> KernelType -> Problem -> IO Model train = train' defaultExtra +-- |Like 'crossvalidate' but with extra parameters crossValidate' :: ExtraParam -> Algorithm -> KernelType @@ -178,11 +192,13 @@ c_svm_cross_validation probPtr paramPtr c_nFold targetPtr map realToFrac `liftM` peekArray probLen targetPtr +-- |Stratified cross validation crossValidate :: Algorithm -> KernelType -> Problem -> Int -> IO [Double] crossValidate = crossValidate' defaultExtra ----------------------------------------------------------------------- +-- |Save model to the file saveModel :: Model -> FilePath -> IO () saveModel (Model modelForeignPtr) path = withForeignPtr modelForeignPtr $ \modelPtr -> do @@ -190,15 +206,32 @@ ret <- c_svm_save_model pathString modelPtr when (ret /= 0) $ error $ "svm: error saving the model:" ++ show ret +-- |Load model from the file loadModel :: FilePath -> IO Model loadModel path = do modelPtr <- c_svm_load_model =<< newCString path Model `liftM` newForeignPtr c_svm_destroy_model modelPtr ---- +-- |Predict a value for 'Vector' by using 'Model' predict :: Model -> Vector -> IO Double predict (Model modelForeignPtr) vector = action where action :: IO Double action = withForeignPtr modelForeignPtr $ \modelPtr -> withCSvmNodeArray vector $ \vectorPtr -> - return . realToFrac . c_svm_predict modelPtr $ vectorPtr + realToFrac <$> c_svm_predict modelPtr vectorPtr + +-- |Wrapper to change the libsvm output reporting function. +-- +-- libsvm by default writes some statistics to stdout. If you don't +-- want any output from libsvm, you can do e.g.: +-- +-- >>> withPrintFn (\_ -> return ()) $ train (NuSvc 0.25) (RBF 1) feats +withPrintFn :: CSvmPrintFn -> IO a -> IO a +withPrintFn printfn body = bracket + (do + c_printfn <- createSvmPrintFnPtr printfn + c_svm_set_print_string_function c_printfn + return c_printfn + ) + freeHaskellFunPtr + (const body) diff --git a/Data/SVM/Raw.hsc b/Data/SVM/Raw.hsc --- a/Data/SVM/Raw.hsc +++ b/Data/SVM/Raw.hsc @@ -1,3 +1,6 @@ +{-|This is a module with raw bindings to libsvm +-} + {-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, EmptyDataDecls #-} @@ -10,13 +13,10 @@ module Data.SVM.Raw where --- TODO limitare l'export --- TODO verificare l'import - import Foreign.Storable (Storable(..), peekByteOff, pokeByteOff) import Foreign.C.Types (CDouble (..), CInt (..)) import Foreign.C.String (CString) -import Foreign.Ptr(nullPtr, Ptr) +import Foreign.Ptr(nullPtr, Ptr, FunPtr) import Foreign.ForeignPtr (FinalizerPtr) data CSvmNode = CSvmNode { @@ -51,7 +51,6 @@ (#poke struct svm_problem, x) ptr xp --- TODO esportare solo il tipo e non il costruttore? newtype CSvmType = CSvmType {unCSvmType :: CInt} deriving (Storable, Show) #enum CSvmType, CSvmType, C_SVC, NU_SVC, ONE_CLASS, EPSILON_SVR, NU_SVR @@ -122,14 +121,14 @@ (#poke struct svm_parameter, shrinking) ptr shrinking_p (#poke struct svm_parameter, probability) ptr probability_p +-- |Managed type for struct svm_model. data CSvmModel --- TODO cambiare il return type da foreign import ccall unsafe "svm.h svm_train" c_svm_train :: Ptr CSvmProblem -> Ptr CSvmParameter -> IO (Ptr CSvmModel) foreign import ccall unsafe "svm.h svm_cross_validation" c_svm_cross_validation:: Ptr CSvmProblem -> Ptr CSvmParameter -> CInt -> Ptr CDouble -> IO () -foreign import ccall unsafe "svm.h svm_predict" c_svm_predict :: Ptr CSvmModel -> Ptr CSvmNode -> CDouble +foreign import ccall unsafe "svm.h svm_predict" c_svm_predict :: Ptr CSvmModel -> Ptr CSvmNode -> IO CDouble foreign import ccall unsafe "svm.h svm_save_model" c_svm_save_model :: CString -> Ptr CSvmModel -> IO CInt @@ -140,3 +139,8 @@ foreign import ccall unsafe "svm.h &svm_destroy_model" c_svm_destroy_model :: FinalizerPtr CSvmModel foreign import ccall unsafe "svm.h clone_model_support_vectors" c_clone_model_support_vectors :: Ptr CSvmModel -> IO CInt + +type CSvmPrintFn = CString -> IO () + +foreign import ccall unsafe "svm.h svm_set_print_string_function" c_svm_set_print_string_function :: FunPtr CSvmPrintFn -> IO () +foreign import ccall unsafe "wrapper" createSvmPrintFnPtr :: CSvmPrintFn -> IO (FunPtr CSvmPrintFn) diff --git a/HSvm.cabal b/HSvm.cabal --- a/HSvm.cabal +++ b/HSvm.cabal @@ -1,5 +1,5 @@ Name: HSvm -Version: 0.1.0.3.22 +Version: 0.1.1.3.22 Copyright: (c) 2009 Paolo Losi, 2017 Pavel Ryzhov Maintainer: Pavel Ryzhov License: BSD3 @@ -19,7 +19,8 @@ Library Build-Depends: base >= 4 && < 5 , containers - Exposed-modules: Data.SVM, Data.SVM.Raw + Exposed-modules: Data.SVM + , Data.SVM.Raw Includes: svm.h Include-Dirs: cbits C-Sources: cbits/svm.cpp diff --git a/cbits/svm.cpp b/cbits/svm.cpp --- a/cbits/svm.cpp +++ b/cbits/svm.cpp @@ -2598,7 +2598,7 @@ double svm_predict(const svm_model *model, const svm_node *x) { - print_node(x); + // print_node(x); int nr_class = model->nr_class; double *dec_values; if(model->param.svm_type == ONE_CLASS ||