diff --git a/AI/SVM/Base.hs b/AI/SVM/Base.hs --- a/AI/SVM/Base.hs +++ b/AI/SVM/Base.hs @@ -24,6 +24,8 @@ SVM , SVMType(..), Kernel(..) , SVMVector(..) + , SVMNodes + ,getNRClasses -- * File operations ,loadSVM, saveSVM @@ -33,6 +35,7 @@ ,predict ) where +import AI.SVM.Common import Bindings.SVM import Control.Applicative import Control.Arrow (first, second, (***), (&&&)) @@ -55,49 +58,56 @@ import System.Directory import System.IO.Error import System.IO.Unsafe +import Unsafe.Coerce import qualified Data.ByteString.Lazy as B import qualified Data.Map as Map import qualified Data.Vector as GV import qualified Data.Vector.Storable as V import qualified Foreign.Concurrent as C -import AI.SVM.Common +-- | Intermediary type for interfacing with libsvm. If you need to repeatedly train with the same training data, +-- consider using this type for the training. It is slightly faster and allocates a bit less +type SVMNodes = V.Vector C'svm_node + +-- | Class of things that can be interpreted as training vectors for svm. class SVMVector a where - convert :: a -> V.Vector Double + convert :: a -> SVMNodes -instance SVMVector (V.Vector Double) where +instance SVMVector (V.Vector C'svm_node) where convert = id +instance SVMVector (V.Vector Double) where + convert = convertDense + instance SVMVector (GV.Vector Double) where - convert = GV.convert + convert = convertDense . GV.convert instance SVMVector [Double] where - convert = V.fromList + convert = convertDense . V.fromList instance SVMVector (Double,Double) where - convert (a,b) = V.fromList [a,b] + convert (a,b) = convertDense . V.fromList $ [a,b] instance SVMVector (Double,Double,Double) where - convert (a,b,c) = V.fromList [a,b,c] + convert (a,b,c) = convertDense . V.fromList $ [a,b,c] instance SVMVector (Double,Double,Double,Double) where - convert (a,b,c,d) = V.fromList [a,b,c,d] + convert (a,b,c,d) = convertDense . V.fromList $ [a,b,c,d] instance SVMVector (Double,Double,Double,Double,Double) where - convert (a,b,c,d,e) = V.fromList [a,b,c,d,e] - - - + convert (a,b,c,d,e) = convertDense . V.fromList $ [a,b,c,d,e] -{-# SPECIALIZE convertDense :: V.Vector Double -> V.Vector C'svm_node #-} -{-# SPECIALIZE convertDense :: V.Vector Float -> V.Vector C'svm_node #-} -convertDense :: (V.Storable a, Real a) => V.Vector a -> V.Vector C'svm_node +convertDense :: V.Vector Double -> V.Vector C'svm_node convertDense v = V.generate (dim+1) readVal where dim = V.length v readVal !n | n >= dim = C'svm_node (-1) 0 - readVal !n = C'svm_node (fromIntegral n+1) (realToFrac $ v ! n) + readVal !n = C'svm_node (fromIntegral n+1) (double2CDouble $ v ! n) +{-#INLINE double2CDouble #-} +double2CDouble :: Double -> CDouble +double2CDouble = unsafeCoerce + createProblem v = do -- #TODO Check the problem dimension. Libsvm doesn't node_array <- newArray xs class_array <- newArray y @@ -108,13 +118,12 @@ ,node_array) where dim = length v - lengths = map ((+1) . V.length . snd) v + lengths = map (V.length . snd) v offsetPtrs addr = take dim [addr `plusPtr` (idx * sizeOf (C'svm_node undefined undefined)) | idx <- scanl (+) 0 lengths] y = map (realToFrac . fst) v - xs = concatMap (V.toList . extractSvmNode . snd) v - extractSvmNode x = convertDense $ V.generate (V.length x) (x !) + xs = concatMap (V.toList . snd) v deleteProblem (C'svm_problem l class_array offset_array , node_array) = free class_array >> free offset_array >> free node_array @@ -169,12 +178,12 @@ = fromIntegral <$> withForeignPtr fptr c'svm_get_nr_class -- | Predict the class of a vector with an SVM. +{-#SPECIALIZE predict :: SVM -> SVMNodes -> Double #-} predict :: (SVMVector a) => SVM -> a -> Double predict (getModelPtr -> fptr) - (convert -> vec) = unsafePerformIO $ + (convert -> nodes) = unsafePerformIO $ withForeignPtr fptr $ \modelPtr -> - let nodes = convertDense vec - in realToFrac <$> V.unsafeWith nodes + realToFrac <$> V.unsafeWith nodes (c'svm_predict modelPtr) defaultParamers = C'svm_parameter { @@ -312,6 +321,7 @@ wrapPrintF :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) -- |Create an SVM from the training data +{-#SPECIALIZE trainSVM :: SVMType -> Kernel -> [(Double,SVMNodes)] -> IO (String,SVM) #-} trainSVM :: (SVMVector a) => SVMType -> Kernel -> [(Double, a)] -> IO (String, SVM) trainSVM svm kernel (map (second convert) -> dataSet) = do messages <- newIORef [] @@ -331,6 +341,7 @@ -- |Cross validate SVM. This is faster than training and predicting for each fold -- separately, since there are no extra conversions done between libsvm and haskell. +{-#SPECIALIZE crossvalidate :: SVMType -> Kernel -> Int -> [(Double,SVMNodes)] -> IO (String,[Double]) #-} crossvalidate :: (SVMVector b) => SVMType -> Kernel -> Int -> [(Double, b)] -> IO (String, [Double]) crossvalidate svm kernel folds (map (second convert) -> dataSet) = do diff --git a/AI/SVM/Simple.hs b/AI/SVM/Simple.hs --- a/AI/SVM/Simple.hs +++ b/AI/SVM/Simple.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, TupleSections, ViewPatterns, - RecordWildCards, FlexibleInstances #-} + RecordWildCards, FlexibleInstances, ForeignFunctionInterface #-} ------------------------------------------------------------------------------- -- | -- Module : Bindings.SVM @@ -60,6 +60,7 @@ import System.IO.Unsafe import qualified Data.ByteString.Lazy as B import qualified Data.Map as Map +import Foreign.C.Types (CInt) import AI.SVM.Common @@ -67,11 +68,13 @@ data ClassifierType = C {cost :: Double} | NU {cost :: Double, nu :: Double} + deriving (Show) -- | Supported SVM regression machines data RegressorType = Epsilon Double Double | NU_r Double Double + deriving (Show) data SVMClassifier a = SVMClassifier SVM (Map a Double) (Map Double a) newtype SVMRegressor = SVMRegressor SVM @@ -123,9 +126,9 @@ -- | Train an SVM classifier of given type. trainClassifier :: (SVMVector b, Ord a) => - ClassifierType - -> Kernel - -> [(a, b)] + ClassifierType -- ^ The type of the classifier + -> Kernel -- ^ Kernel + -> [(a, b)] -- ^ Training data -> (String, SVMClassifier a) trainClassifier ctype kernel dataset = unsafePerformIO $ do let (to,from, doubleDataSet) = convertToDouble dataset @@ -140,10 +143,15 @@ -- | Perform n-foldl cross validation for given set of SVM parameters crossvalidateClassifier :: (SVMVector b, Ord a) => - ClassifierType -> Kernel -> Int -> [(a, b)] + ClassifierType -- ^ The type of classifier + -> Kernel -- ^ Classifier kernel + -> Int -- ^ Number of folds to use + -> [(a, b)] -- ^ Dataset + -> Int -- ^ Seed value. The crossvalidation randomly partitions the data into subsets using this seed value -> (String, [a]) -crossvalidateClassifier ctype kernel folds dataset = unsafePerformIO $ do +crossvalidateClassifier ctype kernel folds dataset seed = unsafePerformIO $ do let (to,from, doubleDataSet) = convertToDouble dataset + c_srand (fromIntegral seed) (m,res :: [Double]) <- crossvalidate (generalizeClassifier ctype) kernel folds doubleDataSet return . (m,) $ map (from Map.!) res where @@ -181,8 +189,16 @@ (m,svm) <- trainSVM (generalizeRegressor rtype) kernel doubleDataSet return . (m,) $ SVMRegressor svm -crossvalidateRegressor rtype kernel folds dataset = unsafePerformIO $ do +crossvalidateRegressor :: (SVMVector b) => + RegressorType -- ^ The type of the regressor + -> Kernel -- ^ Kernel + -> Int -- ^ Number of folds to use + -> [(Double, b)] -- ^ Dataset + -> Int -- ^ Seed value. The crossvalidation randomly partitions the data into subsets using this seed value + -> (String, [Double]) +crossvalidateRegressor rtype kernel folds dataset seed = unsafePerformIO $ do let doubleDataSet = map (second convert) dataset + c_srand (fromIntegral seed) (m,res) <- crossvalidate (generalizeRegressor rtype) kernel folds doubleDataSet return (m,res) @@ -190,4 +206,5 @@ predictRegression :: SVMVector a => SVMRegressor -> a -> Double predictRegression (SVMRegressor svm) (convert -> v) = predict svm v +foreign import ccall "srand" c_srand :: CInt -> IO () diff --git a/Examples/Plot.hs b/Examples/Plot.hs --- a/Examples/Plot.hs +++ b/Examples/Plot.hs @@ -19,15 +19,15 @@ ] let (m,svm2) = trainClassifier (C 1) (RBF 4) trainingData let plot = - (circle # fc green # scale 5 ) + (circle # fc green # scale 5 5 ) `atop` - (circle # fc green # scale 5 - `atop` circle # scale 100 # lineWidth 5) # translate (200,200) + (circle # fc green # scale 5 5 + `atop` circle # scale 100 100 # lineWidth 5) # translate (200,200) `atop` - (circle # fc green # scale 5 # translate (400,400) ) + (circle # fc green # scale 5 5 # translate (400,400) ) `atop` - foldl (atop) (circle # scale 1) - [circle # scale 5 # translate (400*x,400*y) # fc (color svm2 (x,y)) + foldl (atop) (circle # scale 1 1) + [circle # scale 5 5 # translate (400*x,400*y) # fc (color svm2 (x,y)) | x <- [0,0.025..1], y <- [0,0.025..1]] fst $ renderDia Cairo (CairoOptions ("test.png") (PNG (400,400))) plot where diff --git a/svm-simple.cabal b/svm-simple.cabal --- a/svm-simple.cabal +++ b/svm-simple.cabal @@ -1,5 +1,5 @@ name: svm-simple -version: 0.2.5 +version: 0.2.6 synopsis: Medium level, simplified, bindings to libsvm description: This is a set of simplified bindings to libsvm suite @@ -7,6 +7,12 @@ and support vector regression. . . + Changes in version 0.2.6 + . + * Fixed a critical bug with training and crossvalidation + . + * Slight performance improvements + . Changes in version 0.2.5 . * Crossvalidation for the high level interface @@ -14,11 +20,10 @@ Changes in version 0.2.2 . * Rather ugly binary instances - * Exporting SVM types . Changes in version 0.2.1 . - * Added operations for saving and loading SVMs to the 'Simple'-interface. + * Added operations for saving and loading SVMs . Changes in version 0.2.0 . @@ -57,6 +62,6 @@ bindings-svm >= 0.2.0 && < 0.3, binary >= 0.5 && < 0.6, mwc-random >= 0.8 && < 0.9, - vector >= 0.7.0.1 && < 0.8, + vector >= 0.7.0.1 && < 1.1, directory >= 1.1.0.0 && < 1.2, containers >= 0.4.0.0 && < 0.5