data(iris)
head(iris)
##   Sepal.Length Sepal.Width Petal.Length Petal.Width Species
## 1          5.1         3.5          1.4         0.2  setosa
## 2          4.9         3.0          1.4         0.2  setosa
## 3          4.7         3.2          1.3         0.2  setosa
## 4          4.6         3.1          1.5         0.2  setosa
## 5          5.0         3.6          1.4         0.2  setosa
## 6          5.4         3.9          1.7         0.4  setosa
#install.packages("rpart")
library(rpart)
## Warning: package 'rpart' was built under R version 3.2.5
fit <- rpart(Species ~Sepal.Length + Sepal.Width + Petal.Length + Petal.Width, data=iris)
summary(fit)
## Call:
## rpart(formula = Species ~ Sepal.Length + Sepal.Width + Petal.Length + 
##     Petal.Width, data = iris)
##   n= 150 
## 
##     CP nsplit rel error xerror       xstd
## 1 0.50      0      1.00   1.16 0.05127703
## 2 0.44      1      0.50   0.68 0.06096994
## 3 0.01      2      0.06   0.08 0.02751969
## 
## Variable importance
##  Petal.Width Petal.Length Sepal.Length  Sepal.Width 
##           34           31           21           14 
## 
## Node number 1: 150 observations,    complexity param=0.5
##   predicted class=setosa      expected loss=0.6666667  P(node) =1
##     class counts:    50    50    50
##    probabilities: 0.333 0.333 0.333 
##   left son=2 (50 obs) right son=3 (100 obs)
##   Primary splits:
##       Petal.Length < 2.45 to the left,  improve=50.00000, (0 missing)
##       Petal.Width  < 0.8  to the left,  improve=50.00000, (0 missing)
##       Sepal.Length < 5.45 to the left,  improve=34.16405, (0 missing)
##       Sepal.Width  < 3.35 to the right, improve=19.03851, (0 missing)
##   Surrogate splits:
##       Petal.Width  < 0.8  to the left,  agree=1.000, adj=1.00, (0 split)
##       Sepal.Length < 5.45 to the left,  agree=0.920, adj=0.76, (0 split)
##       Sepal.Width  < 3.35 to the right, agree=0.833, adj=0.50, (0 split)
## 
## Node number 2: 50 observations
##   predicted class=setosa      expected loss=0  P(node) =0.3333333
##     class counts:    50     0     0
##    probabilities: 1.000 0.000 0.000 
## 
## Node number 3: 100 observations,    complexity param=0.44
##   predicted class=versicolor  expected loss=0.5  P(node) =0.6666667
##     class counts:     0    50    50
##    probabilities: 0.000 0.500 0.500 
##   left son=6 (54 obs) right son=7 (46 obs)
##   Primary splits:
##       Petal.Width  < 1.75 to the left,  improve=38.969400, (0 missing)
##       Petal.Length < 4.75 to the left,  improve=37.353540, (0 missing)
##       Sepal.Length < 6.15 to the left,  improve=10.686870, (0 missing)
##       Sepal.Width  < 2.45 to the left,  improve= 3.555556, (0 missing)
##   Surrogate splits:
##       Petal.Length < 4.75 to the left,  agree=0.91, adj=0.804, (0 split)
##       Sepal.Length < 6.15 to the left,  agree=0.73, adj=0.413, (0 split)
##       Sepal.Width  < 2.95 to the left,  agree=0.67, adj=0.283, (0 split)
## 
## Node number 6: 54 observations
##   predicted class=versicolor  expected loss=0.09259259  P(node) =0.36
##     class counts:     0    49     5
##    probabilities: 0.000 0.907 0.093 
## 
## Node number 7: 46 observations
##   predicted class=virginica   expected loss=0.02173913  P(node) =0.3066667
##     class counts:     0     1    45
##    probabilities: 0.000 0.022 0.978
plot(fit, margin = 0.1)
text(fit)

plot(iris$Petal.Length, iris$Petal.Width)

plot(iris$Petal.Length, iris$Petal.Width, col="red")

plot(iris$Petal.Length, iris$Petal.Width, col=iris$Species)
abline(v=2.45, col="red")
abline(h=1.75, col="blue")

newpt = data.frame(Petal.Width = 2.2, Petal.Length = 3.5, Sepal.Length = 2, Sepal.Width = 2)
predict(fit, newpt)
##   setosa versicolor virginica
## 1      0 0.02173913 0.9782609
pred <- predict(fit, iris)
pred <- predict(fit, iris, type="class")

t <- c(1,1,0,1,0)
p <- c(0,1,0,1,1)
table(t,p)
##    p
## t   0 1
##   0 1 1
##   1 1 2
cm <- table(pred, iris$Species)
#install.packages("caret")
library(caret)
## Loading required package: lattice
## Loading required package: ggplot2
confusionMatrix(cm)
## Confusion Matrix and Statistics
## 
##             
## pred         setosa versicolor virginica
##   setosa         50          0         0
##   versicolor      0         49         5
##   virginica       0          1        45
## 
## Overall Statistics
##                                          
##                Accuracy : 0.96           
##                  95% CI : (0.915, 0.9852)
##     No Information Rate : 0.3333         
##     P-Value [Acc > NIR] : < 2.2e-16      
##                                          
##                   Kappa : 0.94           
##  Mcnemar's Test P-Value : NA             
## 
## Statistics by Class:
## 
##                      Class: setosa Class: versicolor Class: virginica
## Sensitivity                 1.0000            0.9800           0.9000
## Specificity                 1.0000            0.9500           0.9900
## Pos Pred Value              1.0000            0.9074           0.9783
## Neg Pred Value              1.0000            0.9896           0.9519
## Prevalence                  0.3333            0.3333           0.3333
## Detection Rate              0.3333            0.3267           0.3000
## Detection Prevalence        0.3333            0.3600           0.3067
## Balanced Accuracy           1.0000            0.9650           0.9450
set.seed(123)
sample.int(42,6)
## [1] 13 33 17 35 36  2
#.Random.seed


sample.int(2, 10, replace=TRUE)
##  [1] 2 2 2 1 2 1 2 2 1 2
idx = sample.int(2, nrow(iris), replace=TRUE)
set.seed(123)
idx = sample.int(2, nrow(iris), replace=TRUE, prob=c(0.7,0.3))
table(idx)
## idx
##   1   2 
## 106  44
trainset <- iris[idx == 1, ]
testset <- iris[idx == 2, ]
fit2 <- rpart(Species ~., data=trainset)
plot(fit2, margin = 0.1)

pred <- predict(fit2, testset[,-5], type= "class")
cm <- table(pred, testset[,5])
confusionMatrix(cm)
## Confusion Matrix and Statistics
## 
##             
## pred         setosa versicolor virginica
##   setosa         15          0         0
##   versicolor      0         10         1
##   virginica       0          4        14
## 
## Overall Statistics
##                                           
##                Accuracy : 0.8864          
##                  95% CI : (0.7544, 0.9621)
##     No Information Rate : 0.3409          
##     P-Value [Acc > NIR] : 8.552e-14       
##                                           
##                   Kappa : 0.8291          
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: setosa Class: versicolor Class: virginica
## Sensitivity                 1.0000            0.7143           0.9333
## Specificity                 1.0000            0.9667           0.8621
## Pos Pred Value              1.0000            0.9091           0.7778
## Neg Pred Value              1.0000            0.8788           0.9615
## Prevalence                  0.3409            0.3182           0.3409
## Detection Rate              0.3409            0.2273           0.3182
## Detection Prevalence        0.3409            0.2500           0.4091
## Balanced Accuracy           1.0000            0.8405           0.8977
#install.packages("C50")
library(C50)
data(churn)
str(churnTrain)
## 'data.frame':    3333 obs. of  20 variables:
##  $ state                        : Factor w/ 51 levels "AK","AL","AR",..: 17 36 32 36 37 2 20 25 19 50 ...
##  $ account_length               : int  128 107 137 84 75 118 121 147 117 141 ...
##  $ area_code                    : Factor w/ 3 levels "area_code_408",..: 2 2 2 1 2 3 3 2 1 2 ...
##  $ international_plan           : Factor w/ 2 levels "no","yes": 1 1 1 2 2 2 1 2 1 2 ...
##  $ voice_mail_plan              : Factor w/ 2 levels "no","yes": 2 2 1 1 1 1 2 1 1 2 ...
##  $ number_vmail_messages        : int  25 26 0 0 0 0 24 0 0 37 ...
##  $ total_day_minutes            : num  265 162 243 299 167 ...
##  $ total_day_calls              : int  110 123 114 71 113 98 88 79 97 84 ...
##  $ total_day_charge             : num  45.1 27.5 41.4 50.9 28.3 ...
##  $ total_eve_minutes            : num  197.4 195.5 121.2 61.9 148.3 ...
##  $ total_eve_calls              : int  99 103 110 88 122 101 108 94 80 111 ...
##  $ total_eve_charge             : num  16.78 16.62 10.3 5.26 12.61 ...
##  $ total_night_minutes          : num  245 254 163 197 187 ...
##  $ total_night_calls            : int  91 103 104 89 121 118 118 96 90 97 ...
##  $ total_night_charge           : num  11.01 11.45 7.32 8.86 8.41 ...
##  $ total_intl_minutes           : num  10 13.7 12.2 6.6 10.1 6.3 7.5 7.1 8.7 11.2 ...
##  $ total_intl_calls             : int  3 3 5 7 3 6 7 6 4 5 ...
##  $ total_intl_charge            : num  2.7 3.7 3.29 1.78 2.73 1.7 2.03 1.92 2.35 3.02 ...
##  $ number_customer_service_calls: int  1 1 0 2 3 0 3 0 1 0 ...
##  $ churn                        : Factor w/ 2 levels "yes","no": 2 2 2 2 2 2 2 2 2 2 ...
data(churn)
str(churnTrain)
## 'data.frame':    3333 obs. of  20 variables:
##  $ state                        : Factor w/ 51 levels "AK","AL","AR",..: 17 36 32 36 37 2 20 25 19 50 ...
##  $ account_length               : int  128 107 137 84 75 118 121 147 117 141 ...
##  $ area_code                    : Factor w/ 3 levels "area_code_408",..: 2 2 2 1 2 3 3 2 1 2 ...
##  $ international_plan           : Factor w/ 2 levels "no","yes": 1 1 1 2 2 2 1 2 1 2 ...
##  $ voice_mail_plan              : Factor w/ 2 levels "no","yes": 2 2 1 1 1 1 2 1 1 2 ...
##  $ number_vmail_messages        : int  25 26 0 0 0 0 24 0 0 37 ...
##  $ total_day_minutes            : num  265 162 243 299 167 ...
##  $ total_day_calls              : int  110 123 114 71 113 98 88 79 97 84 ...
##  $ total_day_charge             : num  45.1 27.5 41.4 50.9 28.3 ...
##  $ total_eve_minutes            : num  197.4 195.5 121.2 61.9 148.3 ...
##  $ total_eve_calls              : int  99 103 110 88 122 101 108 94 80 111 ...
##  $ total_eve_charge             : num  16.78 16.62 10.3 5.26 12.61 ...
##  $ total_night_minutes          : num  245 254 163 197 187 ...
##  $ total_night_calls            : int  91 103 104 89 121 118 118 96 90 97 ...
##  $ total_night_charge           : num  11.01 11.45 7.32 8.86 8.41 ...
##  $ total_intl_minutes           : num  10 13.7 12.2 6.6 10.1 6.3 7.5 7.1 8.7 11.2 ...
##  $ total_intl_calls             : int  3 3 5 7 3 6 7 6 4 5 ...
##  $ total_intl_charge            : num  2.7 3.7 3.29 1.78 2.73 1.7 2.03 1.92 2.35 3.02 ...
##  $ number_customer_service_calls: int  1 1 0 2 3 0 3 0 1 0 ...
##  $ churn                        : Factor w/ 2 levels "yes","no": 2 2 2 2 2 2 2 2 2 2 ...
churnTrain = churnTrain[,! names(churnTrain) %in% c("state", "area_code", "account_length") ]
set.seed(2)
ind <- sample(2, nrow(churnTrain), replace = TRUE, prob=c(0.7, 0.3))
trainset = churnTrain[ind == 1,]
testset = churnTrain[ind == 2,]
library(rpart)
churn.rp <- rpart(churn ~ ., data=trainset)
plot(churn.rp, margin= 0.1)
text(churn.rp, all=TRUE, use.n = TRUE)

min(churn.rp$cptable[,"xerror"])
## [1] 0.4707602
pos = which.min(churn.rp$cptable[,"xerror"])

churn.cp = churn.rp$cptable[pos,"CP"]

prune.tree = prune(churn.rp, cp= churn.cp)
plot(prune.tree, margin= 0.1)
text(prune.tree, all=TRUE , use.n=TRUE)

predictions <- predict(churn.rp, testset, type="class")
table(testset$churn, predictions)
##      predictions
##       yes  no
##   yes 100  41
##   no   18 859
library(caret)
confusionMatrix(table(predictions, testset$churn))
## Confusion Matrix and Statistics
## 
##            
## predictions yes  no
##         yes 100  18
##         no   41 859
##                                           
##                Accuracy : 0.942           
##                  95% CI : (0.9259, 0.9556)
##     No Information Rate : 0.8615          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.7393          
##  Mcnemar's Test P-Value : 0.004181        
##                                           
##             Sensitivity : 0.70922         
##             Specificity : 0.97948         
##          Pos Pred Value : 0.84746         
##          Neg Pred Value : 0.95444         
##              Prevalence : 0.13851         
##          Detection Rate : 0.09823         
##    Detection Prevalence : 0.11591         
##       Balanced Accuracy : 0.84435         
##                                           
##        'Positive' Class : yes             
## 
pred <- predict(churn.rp, testset)
testset$churn
##    [1] no  no  no  no  no  yes no  no  no  no  yes no  no  no  no  no  no 
##   [18] no  no  no  yes no  no  no  no  no  yes no  yes no  no  no  no  no 
##   [35] no  no  yes no  no  no  no  no  no  no  no  no  no  no  yes no  no 
##   [52] no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  yes
##   [69] no  no  no  no  no  no  no  no  no  yes no  yes no  no  no  no  no 
##   [86] no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  yes yes
##  [103] no  no  yes no  no  no  no  no  no  no  no  no  no  no  no  no  yes
##  [120] yes no  no  no  no  yes no  no  no  no  no  no  yes no  no  no  no 
##  [137] yes yes no  no  no  yes no  no  no  no  no  no  no  no  no  no  no 
##  [154] no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  yes no 
##  [171] yes no  no  no  no  no  no  no  no  no  no  no  no  no  yes no  no 
##  [188] no  no  no  no  no  yes no  no  no  no  no  no  no  no  no  no  yes
##  [205] no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no 
##  [222] no  no  yes no  no  no  no  no  no  no  no  no  no  no  no  no  no 
##  [239] no  no  no  no  no  no  no  yes no  no  no  no  no  no  no  no  yes
##  [256] no  no  no  no  no  yes no  no  no  no  no  no  no  no  no  no  no 
##  [273] no  yes yes no  no  yes no  no  no  no  yes no  no  no  no  yes no 
##  [290] no  no  no  no  no  yes no  yes no  no  yes no  no  no  no  no  no 
##  [307] yes no  no  no  no  no  no  no  no  yes no  no  no  no  no  no  no 
##  [324] no  no  no  no  no  no  no  no  yes no  no  no  no  no  yes no  no 
##  [341] no  no  no  no  no  no  no  no  no  no  no  no  no  yes no  no  yes
##  [358] no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no 
##  [375] no  yes no  no  no  no  no  no  no  no  no  no  no  no  yes yes no 
##  [392] no  no  no  no  no  no  no  no  no  no  no  no  yes no  no  yes no 
##  [409] no  no  yes no  yes no  no  no  no  no  yes no  yes no  no  no  no 
##  [426] yes no  no  no  no  no  no  no  no  no  yes no  no  no  no  no  no 
##  [443] no  no  no  no  no  no  no  no  no  no  no  no  no  no  yes no  no 
##  [460] no  no  no  no  no  no  no  no  no  yes no  no  no  no  no  no  no 
##  [477] yes yes yes yes no  no  no  no  no  no  no  no  no  no  no  no  no 
##  [494] no  no  no  no  no  no  no  yes no  no  no  yes no  no  no  no  no 
##  [511] no  no  no  yes no  no  no  no  no  no  no  no  no  no  yes no  yes
##  [528] yes no  no  yes no  yes no  no  no  no  no  no  no  no  no  no  no 
##  [545] no  no  yes yes no  no  no  no  yes no  no  no  no  no  no  no  no 
##  [562] no  no  no  no  no  yes no  yes no  yes yes no  yes no  yes no  no 
##  [579] no  no  yes no  no  yes no  no  no  no  no  no  no  no  no  no  no 
##  [596] no  yes no  no  no  no  yes no  no  no  no  yes no  no  no  no  no 
##  [613] no  no  no  no  no  no  no  no  no  no  yes no  yes no  no  no  no 
##  [630] no  no  no  no  no  yes no  no  no  yes no  yes no  no  no  no  no 
##  [647] no  no  no  yes no  no  no  no  no  no  no  no  no  no  no  no  yes
##  [664] no  yes no  no  no  no  no  no  no  no  no  no  no  yes no  no  yes
##  [681] no  no  yes no  no  no  no  no  no  yes no  no  no  no  no  no  no 
##  [698] no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  yes yes
##  [715] no  no  no  no  yes no  no  yes no  no  no  no  yes no  no  yes no 
##  [732] yes no  no  no  no  no  no  no  yes yes no  no  no  no  no  no  no 
##  [749] no  no  yes no  no  no  no  no  no  no  no  no  yes no  no  no  no 
##  [766] no  no  no  no  no  no  no  no  no  no  yes no  no  no  no  no  no 
##  [783] no  no  no  no  no  no  no  yes no  no  yes no  no  no  no  yes no 
##  [800] no  yes no  no  no  no  no  no  no  no  no  yes no  no  no  no  no 
##  [817] no  no  no  no  no  no  no  no  no  no  yes no  yes no  no  no  yes
##  [834] yes no  yes no  no  no  no  no  no  no  yes no  no  no  no  no  no 
##  [851] no  no  yes no  no  no  no  no  no  yes yes yes no  no  yes no  yes
##  [868] no  no  no  no  no  no  no  no  no  no  no  yes no  no  no  no  no 
##  [885] yes no  yes no  no  no  no  no  no  no  no  no  no  no  no  no  no 
##  [902] no  no  no  no  yes yes no  no  no  yes no  no  yes no  yes no  no 
##  [919] no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no 
##  [936] no  no  no  no  yes no  no  no  no  no  yes no  yes no  no  no  no 
##  [953] no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no  no 
##  [970] no  yes no  no  no  no  no  yes no  no  no  yes no  no  no  no  no 
##  [987] no  no  no  no  yes no  no  no  no  no  no  no  no  no  no  no  no 
## [1004] no  no  no  yes no  no  yes no  no  no  no  yes no  no  no 
## Levels: yes no
xary = c()
yary = c()
for(i in seq(0,1,0.1)){
  f <- as.factor(ifelse(pred[,1] > i, 0, 1))
  levels(f) = c("yes", "no")
  tb <- table(f, testset$churn )
  cm <- confusionMatrix(tb)
  y = cm$byClass[1]
  x = 1- cm$byClass[2]
  xary = c(xary, x)
  yary = c(yary, y)
}
library(ROCR)
## Warning: package 'ROCR' was built under R version 3.2.5
## Loading required package: gplots
## Warning: package 'gplots' was built under R version 3.2.5
## 
## Attaching package: 'gplots'
## The following object is masked from 'package:stats':
## 
##     lowess
predictions <- predict(churn.rp, testset, type="prob")
pred.to.roc <- predictions[, 1] 
pred.rocr <- prediction(pred.to.roc, as.factor(testset[,(dim(testset)[[2]])])) 
perf.rocr <- performance(pred.rocr, measure = "auc", x.measure = "cutoff") 
perf.tpr.rocr <- performance(pred.rocr, "tpr","fpr") 
plot(perf.tpr.rocr, colorize=T,main=paste("AUC:",(perf.rocr@y.values)))

download.file('https://github.com/ywchiu/rtibame/raw/master/appledaily2.RData', destfile="appledaily2.RData")
load("appledaily2.RData")
apple.subset = appledaily[appledaily$category %in% c('財經', '娛樂'),]
nrow(apple.subset)
## [1] 234
table(apple.subset$category)
## 
## 娛樂 財經 
##  113  121
library(jiebaR)
## Warning: package 'jiebaR' was built under R version 3.2.5
## Loading required package: jiebaRD
## Warning: package 'jiebaRD' was built under R version 3.2.5
mixseg = worker()
apple.seg =lapply(apple.subset$content, function(e)segment(code=e, jiebar=mixseg))
apple.seg[1]
## [[1]]
##   [1] "台灣浩鼎"   "生技"       "股份"       "有限公司"   "4174"      
##   [6] "今"         "15"         "日"         "中午"       "在"        
##  [11] "法務部"     "公司"       "搜索"       "後"         "再度"      
##  [16] "發布"       "聲明"       "該"         "公司"       "自信"      
##  [21] "一切"       "行事"       "合法"       "絕對"       "積極"      
##  [26] "配合"       "調查"       "協助"       "司法"       "儘速"      
##  [31] "釐清"       "真相"       "但"         "也"         "籲請"      
##  [36] "司法"       "調查"       "單位"       "秉持"       "偵查"      
##  [41] "不"         "公開"       "原則"       "勿將"       "公司"      
##  [46] "基於"       "信任"       "政府"       "和"         "司法"      
##  [51] "在"         "搜索"       "中所"       "交付"       "的"        
##  [56] "商業"       "機密"       "隨意"       "對外"       "公開"      
##  [61] "讓"         "公司"       "數十年"     "研發"       "心血"      
##  [66] "付諸流水"   "將"         "嚴重"       "影響"       "及"        
##  [71] "股東權益"   "並使"       "國內"       "生技"       "產業"      
##  [76] "重挫"       "浩"         "鼎"         "指出"       "檢調"      
##  [81] "搜索"       "後"         "攜"         "走"         "大量"      
##  [86] "資料"       "包括"       "公司"       "許多"       "智財"      
##  [91] "技術"       "和"         "研究"       "數據"       "令"        
##  [96] "員工"       "非常"       "耽憂"       "唯恐"       "在"        
## [101] "研究"       "發表"       "前"         "數據"       "外流"      
## [106] "將"         "嚴重"       "影響"       "公司"       "未來"      
## [111] "發展"       "由於"       "特定"       "媒體"       "已"        
## [116] "連續"       "三周"       "獨家"       "報導"       "浩鼎"      
## [121] "相關"       "訊息"       "報導"       "雖不實"     "但"        
## [126] "部分"       "資料"       "均"         "來自"       "主管"      
## [131] "單位"       "要求"       "公司"       "陳"         "交"        
## [136] "之"         "內部資料"   "這些"       "資料"       "從未"      
## [141] "對外"       "提供"       "今天"       "檢調"       "一抵"      
## [146] "搜索"       "現場"       "該"         "媒體"       "相關"      
## [151] "部門"       "即"         "來電"       "查證"       "在"        
## [156] "偵查"       "不"         "公開"       "下"         "特定"      
## [161] "媒體"       "在"         "第一"       "時間"       "即"        
## [166] "知曉"       "令浩鼎"     "為"         "之"         "驚訝"      
## [171] "與"         "耽憂"       "本"         "公司"       "在"        
## [176] "此"         "嚴正聲明"   "本"         "公司"       "已"        
## [181] "獲邀"       "今年"       "六月"       "將"         "前往"      
## [186] "美國"       "臨床"       "腫瘤"       "醫學會"     "年會"      
## [191] "口頭"       "發表"       "OBI"        "822"        "臨床"      
## [196] "試驗"       "計畫"       "解盲"       "報告"       "論文"      
## [201] "依據"       "學術"       "規範"       "在"         "發表"      
## [206] "前"         "相關"       "數據"       "皆"         "不得"      
## [211] "揭露"       "浩"         "鼎"         "也"         "籲請"      
## [216] "媒體"       "尊重"       "司法"       "若因"       "數據"      
## [221] "外流"       "而"         "導致"       "公司"       "及"        
## [226] "投資人"     "權益"       "損失"       "公司"       "將"        
## [231] "依據"       "營業"       "秘密"       "法"         "及"        
## [236] "相關"       "法規"       "對洩"       "密及"       "傳播者"    
## [241] "追訴"       "及"         "求償"       "浩"         "鼎"        
## [246] "也"         "呼籲"       "投資人"     "不用"       "驚慌"      
## [251] "公司"       "營運"       "正常"       "經得起"     "考驗"      
## [256] "公司"       "也"         "在"         "事前"       "即"        
## [261] "告知"       "員工"       "積極"       "配合"       "調查"      
## [266] "惟有"       "儘速"       "將"         "真相"       "查明"      
## [271] "才能"       "還"         "公司"       "清白"       "20160415"  
## [276] "台灣浩鼎生" "技股"       "有限公司"   "4174"       "今天"      
## [281] "發表聲明"   "公司"       "自信"       "無"         "任何"      
## [286] "不法"       "情事"       "願意"       "主動"       "配合"      
## [291] "司法"       "調查"       "也"         "懇請"       "司法"      
## [296] "單位"       "秉持"       "公平正義"   "原則"       "保障"      
## [301] "合法"       "百姓"       "和"         "業者"       "權益"      
## [306] "早日"       "釐清"       "案情"       "還給"       "浩鼎"      
## [311] "公道"       "江"         "俞"         "庭"         "台北"      
## [316] "報導"
library(tm)
## Loading required package: NLP
## 
## Attaching package: 'NLP'
## The following object is masked from 'package:ggplot2':
## 
##     annotate
jieba_tokenizer=function(d){
  unlist(segment(d[[1]],mixseg))
}
space_tokenizer=function(x){
  unlist(strsplit(as.character(x[[1]]),'[[:space:]]+'))
}
doc=VCorpus(VectorSource(apple.seg))
doc=unlist(tm_map(doc,jieba_tokenizer),recursive=F)
doc=lapply(doc,function(d)paste(d,collapse=' '))
control.list=list(wordLengths=c(2,Inf),tokenize=space_tokenizer)
dtm=DocumentTermMatrix(Corpus(VectorSource(doc)),control=control.list)
dim(dtm)
## [1]   234 10887
ft <- findFreqTerms(dtm, 5)
control.list=list(wordLengths=c(2,Inf),tokenize=space_tokenizer,dictionary =ft)
new.dtm=DocumentTermMatrix(Corpus(VectorSource(doc)),control=control.list)

convert_counts <- function(x) {
  x <- ifelse(x > 0, 1, 0)
  x <- factor(x, levels = c(0, 1), labels = c("No", "Yes"))
  return(x)
}

dtm.count <- apply(new.dtm, MARGIN = 2, convert_counts)
class(dtm.count)
## [1] "matrix"
m<-as.data.frame(dtm.count)
class(m)
## [1] "data.frame"
nrow(m)
## [1] 234
idx <- sample.int(2, nrow(m), replace=TRUE, prob=c(0.7,0.3))
trainset <- m[idx==1,]
testset <- m[idx==2,]
traintag <- apple.subset[idx==1,"category"]
testtag <-apple.subset[idx==2,"category"]
#install.packages("e1071")
library(e1071)
## Warning: package 'e1071' was built under R version 3.2.5
model <- naiveBayes(trainset , as.factor(traintag) )
pred <- predict(model, testset)
tb <- table(pred, testtag)
confusionMatrix(tb)
## Confusion Matrix and Statistics
## 
##       testtag
## pred   娛樂 財經
##   娛樂   35    2
##   財經    0   29
##                                           
##                Accuracy : 0.9697          
##                  95% CI : (0.8948, 0.9963)
##     No Information Rate : 0.5303          
##     P-Value [Acc > NIR] : 1.147e-15       
##                                           
##                   Kappa : 0.9389          
##  Mcnemar's Test P-Value : 0.4795          
##                                           
##             Sensitivity : 1.0000          
##             Specificity : 0.9355          
##          Pos Pred Value : 0.9459          
##          Neg Pred Value : 1.0000          
##              Prevalence : 0.5303          
##          Detection Rate : 0.5303          
##    Detection Prevalence : 0.5606          
##       Balanced Accuracy : 0.9677          
##                                           
##        'Positive' Class : 娛樂            
## 
which(testtag != pred)
## [1] 50 61
apple.subset[idx==2,"title"][which(testtag != pred)]
## [1] "【壹週刊】從貴婦到攤販 看見台灣媳婦的堅毅"
## [2] "HTC 10影片18秒處 網熱議M7藍再現?"
apple.subset[idx==2,"content"][which(testtag != pred)]
## [1] "本內容由台灣壹週刊提供<U+00A0>台灣媳婦林素蓮,原本是旅居巴基斯坦及杜拜的貴婦,2009年她帶著長子林恩勝回台,躲避巴基斯坦的內戰烽火....<U+00A0>「看完整內容請點我」「看更多壹週刊內容請點我」<U+00A0><U+00A0><U+00A0>"                                                                                                                                                                                                                                                                             
## [2] "HTC 10官方影片First Impressions 宏達電新機HTC 10話題不斷,眼尖的網友從官方影片看出,可能將推出天空藍?批踢踢熱議很期待,超愛M7藍,10上藍色應該也很美。<U+00A0>批踢踢網友分享HTC 10官方影片「HTC 10:first Impressions」,18秒的地方,機身標籤貼紙出現「天空藍」的字樣,網友甚至截圖下來,看得更清楚,「有沒有可能是眾所期待的藍色機身呢?」<U+00A0>如果是M7的藍,真的超好看,現在已是絕響,「這藍色不錯,買定了」。(馬婉珍/綜合報導)<U+00A0> 批踢踢網友截圖影片第18秒處,可見「天空藍」字樣。翻攝自HTC上傳YouTube"
testtag[54]
## [1] "娛樂"

預測新聞類別

library(jiebaR)
library(tm)
library(e1071)
apple.subset = appledaily[appledaily$category %in% c('財經', '娛樂', '政治', '體育', '國際'),]
mixseg = worker()
apple.seg =lapply(apple.subset$content, function(e)segment(code=e, jiebar=mixseg))

jieba_tokenizer=function(d){
  unlist(segment(d[[1]],mixseg))
}
space_tokenizer=function(x){
  unlist(strsplit(as.character(x[[1]]),'[[:space:]]+'))
}
doc=VCorpus(VectorSource(apple.seg))
doc=unlist(tm_map(doc,jieba_tokenizer),recursive=F)
doc=lapply(doc,function(d)paste(d,collapse=' '))
control.list=list(wordLengths=c(2,Inf),tokenize=space_tokenizer)
dtm=DocumentTermMatrix(Corpus(VectorSource(doc)),control=control.list)

ft <- findFreqTerms(dtm, 5)
control.list=list(wordLengths=c(2,Inf),tokenize=space_tokenizer,dictionary =ft)
new.dtm=DocumentTermMatrix(Corpus(VectorSource(doc)),control=control.list)


convert_counts <- function(x) {
  x <- ifelse(x > 0, 1, 0)
  x <- factor(x, levels = c(0, 1), labels = c("No", "Yes"))
  return(x)
}

dtm.count <- apply(new.dtm, MARGIN = 2, convert_counts)

m<-as.data.frame(dtm.count)
idx <- sample.int(2, nrow(m), replace=TRUE, prob=c(0.7,0.3))
trainset <- m[idx==1,]
testset <- m[idx==2,]
traintag <- apple.subset[idx==1,"category"]
testtag <-apple.subset[idx==2,"category"]

model <- naiveBayes(trainset , as.factor(traintag) )
pred <- predict(model, testset)
tb <- table(pred, testtag)
confusionMatrix(tb)
## Confusion Matrix and Statistics
## 
##       testtag
## pred   政治 娛樂 財經 國際 體育
##   政治   47    1    1    1    0
##   娛樂    0   32    1    0    1
##   財經    1    0   30    2    0
##   國際    3    2    6   84    1
##   體育    0    0    0    0   25
## 
## Overall Statistics
##                                           
##                Accuracy : 0.916           
##                  95% CI : (0.8732, 0.9479)
##     No Information Rate : 0.3655          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.8883          
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: 政治 Class: 娛樂 Class: 財經 Class: 國際
## Sensitivity               0.9216      0.9143      0.7895      0.9655
## Specificity               0.9840      0.9901      0.9850      0.9205
## Pos Pred Value            0.9400      0.9412      0.9091      0.8750
## Neg Pred Value            0.9787      0.9853      0.9610      0.9789
## Prevalence                0.2143      0.1471      0.1597      0.3655
## Detection Rate            0.1975      0.1345      0.1261      0.3529
## Detection Prevalence      0.2101      0.1429      0.1387      0.4034
## Balanced Accuracy         0.9528      0.9522      0.8872      0.9430
##                      Class: 體育
## Sensitivity               0.9259
## Specificity               1.0000
## Pos Pred Value            1.0000
## Neg Pred Value            0.9906
## Prevalence                0.1134
## Detection Rate            0.1050
## Detection Prevalence      0.1050
## Balanced Accuracy         0.9630
library(e1071)
data(iris)
fit = svm(Species ~., data=iris)
pred = predict(fit, iris)
table(pred, iris$Species)
##             
## pred         setosa versicolor virginica
##   setosa         50          0         0
##   versicolor      0         48         2
##   virginica       0          2        48
df = data.frame(x = c(1,2,3), y = c(2,3,4))
plot(df$x, df$y)

str(df)
## 'data.frame':    3 obs. of  2 variables:
##  $ x: num  1 2 3
##  $ y: num  2 3 4
df$x = as.factor(df$x)
str(df)
## 'data.frame':    3 obs. of  2 variables:
##  $ x: Factor w/ 3 levels "1","2","3": 1 2 3
##  $ y: num  2 3 4
plot(df$x, df$y)

m = matrix(1:9, nrow=3)
apply(m, MARGIN = 2, sum)
## [1]  6 15 24
apply(m, MARGIN = 1, sum)
## [1] 12 15 18
m = matrix(c(1,2,0,0,0,2,0,1,0), nrow=3)
m
##      [,1] [,2] [,3]
## [1,]    1    0    0
## [2,]    2    0    1
## [3,]    0    2    0
apply(m, MARGIN = 2, convert_counts)
##      [,1]  [,2]  [,3] 
## [1,] "Yes" "No"  "No" 
## [2,] "Yes" "No"  "Yes"
## [3,] "No"  "Yes" "No"