样本数据 - II.Rmd

---
title: "盈利模式"
subtitle: "分析购彩助手数据 (第II部)"
author: "特邀导师 - 菜菜 <img src='文艺坊图库/景知夏小姐.jpg' height='24'>"
date: "`r lubridate::today()`"
output:
  html_document: 
    mathjax: https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js
    number_sections: yes
    toc: yes
    toc_depth: 4
    toc_float:
      collapsed: yes
      smooth_scroll: yes
    code_folding: hide
    css: CSSBackgrounds.css
  html_notebook: 
    mathjax: https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js
    number_sections: yes
    toc: yes
    toc_depth: 4
    toc_float:
      collapsed: yes
      smooth_scroll: yes
    code_folding: hide
    css: CSSBackgrounds.css
---

# 主题

<img src='文艺坊图库/商场如战场.png' width='560'>

[[**主题曲**]{style="color:blue"}](https://github.com/englianhu/report/discussions)

🚄东方快车，🚄一带一路。

<audio controls loop autoplay src="文艺坊歌曲库/東方快車合唱團 Oriental Express - 紅紅青春敲呀敲 《黑松沙士》廣告主題曲.mp3" controls></audio>

<br><br>

# 设定

## SCSS 设置

<style>
pre {
  overflow-x: auto;
}
pre code {
  word-wrap: normal;
  white-space: pre;
}
.table-hover > tbody > tr:hover { 
  background-color: #8D918D;
}
</style>

```{r load-sass, class.source='bg-success', class.output='bg-primary'}
# install.packages('remotes', dependencies = TRUE, INSTALL_opts = '--no-lock')
library('BBmisc', 'rmsfuns')
#remotes::install_github("rstudio/sass")
lib('sass')

## https://support.rstudio.com/hc/en-us/articles/200532197
## https://community.rstudio.com/t/r-does-not-display-korean-chinese/30889/3?u=englianhu
#Sys.setlocale("LC_CTYPE", "en_US.UTF-8")
#Sys.setlocale("LC_CTYPE", "zh_CN.UTF-8")
#Sys.setlocale(category = "LC_CTYPE", "Chinese (Simplified)_China.936")
#Sys.setlocale(locale = "Chinese")
#Sys.setlocale(locale = "Japanese")
#Sys.setlocale(locale = "English")

# rmarkdown::render('/home/englianhu/Documents/owner/ryo-cn.Rmd',  encoding = 'UTF-8')
#Sys.setlocale("LC_CTYPE", "UTF-8")
#Sys.setlocale(locale = "UTF-8")
#Sys.setlocale(category = "LC_ALL", locale = "chs")
#Sys.setlocale(category = "LC_ALL", locale = "UTF-8")
#Sys.setlocale(category = "LC_ALL", locale = "Chinese")
#Sys.setlocale(category = "LC_ALL", locale = "zh_CN.UTF-8")
Sys.setlocale("LC_ALL", "en_US.UTF-8")
```

```{scss set-scss, class.source='bg-success', class.output='bg-primary'}
/* https://stackoverflow.com/a/66029010/3806250 */
h1 { color: #002C54; }
h2 { color: #2F496E; }
h3 { color: #375E97; }
h4 { color: #556DAC; }
h5 { color: #92AAC7; }

/* ----------------------------------------------------------------- */
/* https://gist.github.com/himynameisdave/c7a7ed14500d29e58149#file-broken-gradient-animation-less */
.hover01 {
  /* color: #FFD64D; */
  background: linear-gradient(155deg, #EDAE01 0%, #FFEB94 100%);
  transition: all 0.45s;
  &:hover{
    background: linear-gradient(155deg, #EDAE01 20%, #FFEB94 80%);
    }
  }

.hover02 {
  color: #FFD64D;
  background: linear-gradient(155deg, #002C54 0%, #4CB5F5 100%);
  transition: all 0.45s;
  &:hover{
    background: linear-gradient(155deg, #002C54 20%, #4CB5F5 80%);
    }
  }

.hover03 {
  color: #FFD64D;
  background: linear-gradient(155deg, #A10115 0%, #FF3C5C 100%);
  transition: all 0.45s;
  &:hover{
    background: linear-gradient(155deg, #A10115 20%, #FF3C5C 80%);
    }
  }
```

```{r gb-opts, class.source='hover01', class.output='hover02'}
## Set the timezone but not change the datetime
Sys.setenv(TZ = 'Asia/Shanghai')

## Setting to omit all warnings
## https://stackoverflow.com/a/36846793/3806250
## Set width
## options(knitr.table.format = 'html') will set all kableExtra tables to be 'html', otherwise need to set the parameter on every single table.
options(warn = -1, width = 999, knitr.table.format = 'html')#, digits.secs = 6)

## https://stackoverflow.com/questions/39417003/long-vectors-not-supported-yet-abnor-in-rmd-but-not-in-r-script
## https://yihui.org/knitr/options
knitr::opts_chunk$set(
  class.source = 'hover01', class.output = 'hover02', class.error = 'hover03', 
  message = FALSE, warning = FALSE, error = TRUE, 
  autodep = TRUE, aniopts = 'loop', 
  progress = TRUE, verbose = TRUE, 
  cache = FALSE, cache.lazy = FALSE, result = 'asis')
```

<br><br>

## 设置

```{r libs, eval=FALSE}
## Setup Options, Loading Required Libraries and Preparing Environment
## Loading the packages and setting adjustment
source('函数/libs.R')
```

读取程序包

```{r load-pkgs}
## Setup Options, Loading Required Libraries and Preparing Environment
## 3210448065@qq.com
## leiou123

## 2849108450@qq.com
## leiou123
## https://rstudio.cloud/project/1198888

## Loading the package 'BBmisc'
if(suppressMessages(!require('BBmisc'))){
  install.packages('BBmisc', dependencies = TRUE, INSTALL_opts = '--no-lock')
  suppressMessages(library('BBmisc'))
}
if (suppressMessages(!require('rmsfuns'))) {
  install.packages('rmsfuns', dependencies = TRUE, INSTALL_opts = '--no-lock')
  suppressMessages(library('rmsfuns'))
}

if(!require('REmap')) devtools::install_github('lchiffon/REmap')

## Loading multiple packages at once
#pkgs <- c('readr', 'plyr', 'dplyr', 'magrittr', 'tidyverse', 'devtools', 'zoo', 'lubridate', 'stringr', 'rvest', 'markdown', 'googleVis', 'knitr', 'rmarkdown', 'htmltools', 'knitr', 'kableExtra', 'formattable', 'echarts4r', 'radarchart', 'MASS', 'htmlwidgets', 'maps', 'REmap', 'ggmap', 'vembedr')

pkgs <- c('plyr', 'dplyr', 'magrittr', 'stringr', 'knitr', 'kableExtra', 'lubridate', 'broom', 'purrr', 'readxl', 'tibble', 'DT')

suppressAll(lib(pkgs))
load_pkg(pkgs)
rm(pkgs)

## Set the googleVis options first to change the behaviour of plot.gvis, so that 
##  only the chart component of the HTML file is written into the output file.
op <- options(gvis.plot.tag = 'chart')

## <audio src='music/bigmoney.mp3' autoplay controls loop></audio>
```

```{r set-prefer}
conflict_prefer('filter', 'dplyr')
conflict_prefer('select', 'dplyr')
conflict_prefer('mutate', 'dplyr')
conflict_prefer('rename', 'dplyr')
```

<br><br>

# 简介

[盈利模式 - 分析购彩助手数据](https://rpubs.com/englianhu/goucai)使用广义型线性模型`glm`推算出`大`与`单`的出现率较高，<span style='color:goldenrod'>*盈利模式 - 分析购彩助手数据*</span>

<br><br>

# 数据

## 样本数据

账号：`zxg00123`，以下是从我们平台购彩助手中的官方数据采集下来的数据，什么彩种都可以分析，就拿个主打**1分快3**为样本。

![](文艺坊图库/QQ图片20200627153341.png)

```{r read-data}
hml <- read.delim(file = '1分快3样本数据2.txt')
hml %<>% 
  unlist %>% 
  as.character

#时间 期数 号码 大小/单双 鱼虾蟹
#12:41 0761 dice1 dice1 dice57 小 单 鱼 鱼 蟹
smp <- c('12:41', '0761', 'dice1 dice1 dice5', '7 小 单', '鱼 鱼 蟹') %>% 
  matrix(ncol = 1, byrow = TRUE) %>% 
  t %>% 
  data.frame
nm <- c('时间', '期数', '号码', '大小/单双', '鱼虾蟹')
names(smp) <- nm
smp %<>% 
  as_tibble

smp %>% 
  kable(caption = '1分快3样本数据') %>% 
  kable_styling(
    bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(1, color = '#FFFF00', background = '#657383')
```

以上是原始样本数据结构。

## 整理数据

```{r clean-data}
smpp <- hml %>% 
  llply(., function(x) {
    x %>% 
      str_extract_all('([0-9]{2}:[0-9]{2})|([0-9]{1,2}%)|(\\w+)') %>% 
      unlist %>% 
      str_replace_all('2e1d3b04', '') %>% 
      str_replace_all('([0-9]+[a-zA-Z]+)|([a-zA-Z]+)|[0-9]{1,2}%', '') %>% 
      .[nchar(.)>0] %>% 
      t %>% 
      data.frame
    }) %>% 
  bind_rows %>% 
  as_tibble

names(smpp) <- c('时间', '期数', '骰子1', '骰子2', '骰子3', '总值', '大小', '单双', '鱼虾蟹1', '鱼虾蟹2', '鱼虾蟹3')

smpp %<>% mutate(
  `时间` = hm(`时间`), `期数` = factor(`期数`), 
  `骰子1` = as.numeric(`骰子1`), `骰子2` = as.numeric(`骰子2`), 
  `骰子3` = as.numeric(`骰子3`), `总值` = as.numeric(`总值`), 
  `大小` = factor(`大小`), `单双` = factor(`单双`), 
  `鱼虾蟹1` = factor(`鱼虾蟹1`), `鱼虾蟹2` = factor(`鱼虾蟹2`), 
  `鱼虾蟹3` = factor(`鱼虾蟹3`))

smppp <- smpp[c('总值', '大小', '单双')]

smpp %>% 
  datatable(
    caption = "1分快3样本数据", 
    escape = FALSE, filter = 'top', rownames = FALSE, 
    extensions = list(
      'ColReorder' = NULL, 'RowReorder' = NULL, 
      'Buttons' = NULL, 'Responsive' = NULL), 
    options = list(
      dom = 'BRrltpi', autoWidth = TRUE,  scrollX = TRUE, 
      lengthMenu = list(c(10, 50, 100, -1), c('10', '50', '100', 'All')), 
      ColReorder = TRUE, rowReorder = TRUE, 
      buttons = list('copy', 'print', 
                     list(extend = 'collection', 
                          buttons = c('csv', 'excel', 'pdf'), 
                          text = 'Download'), I('colvis'))))
```

以上是整理过的样本数据。

<br><br>

# 统计模型

## 基本分析

```{r prob-overview}
smpp[-c(1:2)] %>% 
  llply(table)
```

```{r prob-tbl}
yy <- suppressMessages(
  llply(3:18, function(i) {
    dpois(i, smppp$总值) %>% 
      round(2)
    }) %>% 
    bind_cols)

names(yy) <- paste0('X', 3:18)
yy <- data.frame(smppp, yy) %>% 
  as_tibble

yy %>% 
  kable(caption = '和值概率明细') %>% 
  kable_styling(
    bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(seq(1, nrow(yy), by = 2), color = '#FFFF00', background = '#657383') %>% 
  row_spec(seq(2, nrow(yy), by = 2), color = '#FFFF00', background = '#C0C0C0') %>% 
  scroll_box(width = '100%', height = '400px')
```

以上图表显示骰子总值从`3`到`18`的概率明细。

```{r prob-dist}
table(smpp$`总值`)
prop.table(table(smpp$`总值`))
barplot(prop.table(table(smpp$`总值`)))
```

以上图表显示骰子总值从`3`到`18`的概率。

```{r}
table(smpp$`大小`)
prop.table(table(smpp$`大小`))
barplot(prop.table(table(smpp$`大小`)))
```

以上图表显示骰子总值开`大`或`小`的概率。

```{r}
table(smpp$`单双`)
prop.table(table(smpp$`单双`))
barplot(prop.table(table(smpp$`单双`)))
```

以上图表显示骰子总值开`单`或`双`的概率。

```{r}
table(smpp$`鱼虾蟹1`)
prop.table(table(smpp$`鱼虾蟹1`))
barplot(prop.table(table(smpp$`鱼虾蟹1`)))
```

以上图表显示骰子总值开`葫`、`虾`、`蟹`、`钱`、`鱼`或`鸡`的概率。

```{r}
table(smpp$`鱼虾蟹2`)
prop.table(table(smpp$`鱼虾蟹2`))
barplot(prop.table(table(smpp$`鱼虾蟹2`)))
```

以上图表显示骰子总值开`葫`、`虾`、`蟹`、`钱`、`鱼`或`鸡`的概率。

```{r}
table(smpp$`鱼虾蟹3`)
prop.table(table(smpp$`鱼虾蟹3`))
barplot(prop.table(table(smpp$`鱼虾蟹3`)))
```

以上图表显示骰子总值开`葫`、`虾`、`蟹`、`钱`、`鱼`或`鸡`的概率。

## 统计建模

### 广义泊松模型 (GLM)

以下是以广义泊松模型预测开奖率。

```{r}
### 计算总值概率

## https://stats.stackexchange.com/questions/272194/interpreting-poisson-output-in-r
md1a <- glm(`总值`~`骰子1`+`骰子2`+`骰子3`, data = smpp, family = poisson)

md1b <- glm(`总值`~`骰子1`+`骰子2`+`骰子3` - 1, data = smpp, family = poisson)

ldply(
  list(md1a, md1b), AIC) %>% 
  data.frame(`模型` = c('截距', '没截距'), .) %>% 
  dplyr::rename(AIC = V1) %>% 
  dplyr::mutate(Rank = rank(AIC)) %>% 
  kable(caption = '统计模型') %>% 
  kable_styling(
    bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(1, color = '#FFFF00', background = '#657383') %>% 
  row_spec(2, color = '#FFFF00', background = '#6D7B8D')
```

根据以上模型，`截距`模型比较精准。

```{r}
md1a.pp <- md1a %>% 
  coef %>% 
  exp %>% 
  llply(., function(x) {dpois(3:18, x)}) %>% 
  bind_cols %>% 
  data.frame(x = 3:18, .)

names(md1a.pp) <- c('x', '截距', '骰子1', '骰子2', '骰子3')
md1a.pp %>% 
  kable(caption = '统计模型') %>% 
  kable_styling(
    bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(seq(1, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#657383') %>% 
  row_spec(seq(2, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#C0C0C0') %>% 
  scroll_box(width = '100%', height = '400px')
```

### 计算大小概率

```{r}
md2a <- glm(as.numeric(`大小`)~`骰子1`+`骰子2`+`骰子3`, data = smpp, family = poisson)

md2b <- glm(as.numeric(`大小`)~`骰子1`+`骰子2`+`骰子3` - 1, data = smpp, family = poisson)

ldply(list(md2a, md2b), AIC) %>% 
  data.frame(`模型` = c('截距', '没截距'), .) %>% 
  dplyr::rename(AIC = V1) %>% 
  dplyr::mutate(Rank = rank(AIC)) %>% 
  kable(caption = '统计模型') %>% 
  kable_styling(
    bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(1, color = '#FFFF00', background = '#657383') %>% 
  row_spec(2, color = '#FFFF00', background = '#6D7B8D')
```

根据以上模型，`截距`模型比较精准。

```{r}
md2a.pp <- md2a %>% 
  coef %>% 
  exp %>% 
  llply(., function(x) {dpois(1:18, x)}) %>% 
  bind_cols %>% 
  data.frame(x = 1:18, .)

names(md1a.pp) <- c('x', '截距', '骰子1', '骰子2', '骰子3')
md1a.pp %>% 
  kable(caption = '统计模型') %>% 
  kable_styling(
  bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(seq(1, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#657383') %>% 
  row_spec(seq(2, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#C0C0C0') %>% 
  scroll_box(width = '100%', height = '400px')
```

### 计算单双概率

```{r}
md3a <- glm(as.numeric(`单双`)~`骰子1`+`骰子2`+`骰子3`, data = smpp, family = poisson)

md3b <- glm(as.numeric(`单双`)~`骰子1`+`骰子2`+`骰子3` - 1, data = smpp, family = poisson)

ldply(list(md3a, md3b), AIC) %>% 
  data.frame(`模型` = c('截距', '没截距'), .) %>% 
  dplyr::rename(AIC = V1) %>% 
  dplyr::mutate(Rank = rank(AIC)) %>% 
  kable(caption = '统计模型') %>% 
  kable_styling(
    bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(1, color = '#FFFF00', background = '#657383') %>% 
  row_spec(2, color = '#FFFF00', background = '#6D7B8D')
```

根据以上模型，`截距`模型比较精准。

```{r}
md3a.pp <- md3a %>% 
  coef %>% 
  exp %>% 
  llply(., function(x) {dpois(1:6, x)}) %>% 
  bind_cols %>% 
  data.frame(x = 1:6, .)

names(md1a.pp) <- c('x', '截距', '骰子1', '骰子2', '骰子3')

md1a.pp %>% 
  kable(caption = '统计模型') %>% 
  kable_styling(
  bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(seq(1, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#657383') %>% 
  row_spec(seq(2, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#C0C0C0') %>% 
  scroll_box(width = '100%', height = '400px')
```

```{r}
## load function files
pth <- paste0('函数/bivpois/R/', list.files(path = '函数/bivpois/R/'))
l_ply(pth, source)

attr(smpp$单双,'contrasts') <- stats::contrasts(stats::C(factor(smpp$单双), sum))
attr(smpp$大小,'contrasts') <- stats::contrasts(stats::C(factor(smpp$大小), sum))
attr(smpp$单双,'levels') <- levels(factor(smpp$单双))
attr(smpp$大小,'levels') <- levels(factor(smpp$大小))

## formula for modeling of lambda1 and lambda2
#form1 <- ~c(team1,team2)+c(team2,team1)

## Model 1: Double Poisson
#ex4.m1<-lm.bp( g1~1, g2~1, l1l2=form1, zeroL3=TRUE, data=ex4.ita91)

## Models 2-5: bivariate Poisson models
#ex4.m2<-lm.bp(g1~1,g2~1, l1l2=form1, data=ex4.ita91, maxit=2)
#ex4.m3<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team1, data=ex4.ita91, maxit=2)
#ex4.m4<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team2, data=ex4.ita91, maxit=2)
#ex4.m5<-lm.bp(g1~1,g2~1, l1l2=form1, l3=~team1+team2, data=ex4.ita91, maxit=2)

form1 <- ~c('大小', '单双') + c('单双', '大小')
l1 = 总值~1; l2 = 总值~2; l1l2 = NULL; l3 = ~1; data = smppp; common.intercept = FALSE; zeroL3 = FALSE; maxit = 100; pres = 1e-8; verbose = getOption('verbose')

lm.bp(大小 ~ 1, 单双 ~ 2, l1l2 = form1, zeroL3 = TRUE, data = smpp)
lm.bp(大小 ~ 1, 单双 ~ 2, l1l2 = form1, data = smpp, maxit = 2)
lm.bp(大小 ~ 1, 单双 ~ 2, l1l2 = form1, l3 = ~单双, data = smpp, maxit = 2)
lm.bp(大小 ~ 1, 单双 ~ 2, l1l2 = form1, l3 = ~大小+单双, data = smpp, maxit = 2)
```

### 计算大小单双概率

#### 760期

```{r}
dx = glm(as.numeric(大小)~总值-1, family=poisson, data=smppp) %>% 
  coef %>% 
  exp
dx <- dx/sum(1 + dx)
ds = glm(as.numeric(单双)~总值-1, family=poisson, data=smppp) %>% 
  coef %>% 
  exp
ds <- ds/sum(1 + ds)
n760 <- data.frame(dx, ds) %>% 
    dplyr::rename(`开大` = dx, `开单` = ds) %>% 
    dplyr::mutate(`开小` = 1- `开大`, `开双` = 1- `开单`) %>% 
    dplyr::select('开大', '开小', '开单', '开双')

n760[c('开大', '开小', '开单', '开双')] %>% 
  colMeans %>% t %>% 
  kable(caption = '760期为标准') %>% 
  kable_styling(
    bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(1, color = '#FFFF00', background = '#657383')
```

#### 20期

```{r}
##20期为标准
n20 <- llply(21:nrow(smppp), function(i) {
  ii <- i - 20
  dx = glm(as.numeric(大小)~总值-1, family=poisson, data=smppp[c(ii:i),]) %>% 
    coef %>% 
    exp
  dx <- dx/sum(1 + dx)
  ds = glm(as.numeric(单双)~总值-1, family=poisson, data=smppp[c(ii:i),]) %>% 
    coef %>% 
    exp
  ds <- ds/sum(1 + ds)
  data.frame(dx, ds) %>% 
    dplyr::rename(`开大` = dx, `开单` = ds) %>% 
    dplyr::mutate(`开小` = 1- `开大`, `开双` = 1- `开单`) %>% 
    dplyr::select('开大', '开小', '开单', '开双') %>% 
    data.frame(smppp[i,], .)
  }) %>% 
  bind_rows %>% 
  as_tibble

n20 %>% 
  kable(caption = '20期为标准') %>% 
  kable_styling(
  bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(seq(1, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#657383') %>% 
  row_spec(seq(2, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#C0C0C0') %>% 
  scroll_box(width = '100%', height = '400px')
```

以上的数据以`20`期移动数据为标准，然后预测第`21`期移动数据的开奖率。

```{r}
n20[c('开大', '开小', '开单', '开双')] %>% 
  colMeans %>% t %>% 
  kable(caption = '20期为标准') %>% 
  kable_styling(bootstrap_options = c('striped', 'hover', 'condensed', 'responsive'))
```

以上乃`20`期总体开奖该率。

#### 30期

```{r}
##30期为标准
n30 <- llply(31:nrow(smppp), function(i) {
  ii <- i - 30
  dx = glm(as.numeric(大小)~总值-1, family=poisson, data=smppp[c(ii:i),]) %>% 
    coef %>% exp
  dx <- dx/sum(1 + dx)
  ds = glm(as.numeric(单双)~总值-1, family=poisson, data=smppp[c(ii:i),]) %>% 
    coef %>% exp
  ds <- ds/sum(1 + ds)
  data.frame(dx, ds) %>% 
    rename(`开大` = dx, `开单` = ds) %>% 
    mutate(`开小` = 1- `开大`, `开双` = 1- `开单`) %>% 
    select('开大', '开小', '开单', '开双') %>% 
    data.frame(smppp[i,], .)
}) %>% bind_rows %>% as_tibble

n30 %>% 
  kable(caption = '20期为标准') %>% 
  kable_styling(
  bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(seq(1, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#657383') %>% 
  row_spec(seq(2, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#C0C0C0') %>% 
  scroll_box(width = '100%', height = '400px')
```

以上的数据以`30`期移动数据为标准，然后预测第`31`期移动数据的开奖率。

```{r}
n30[c('开大', '开小', '开单', '开双')] %>% 
  colMeans %>% t %>% 
  kable(caption = '30期为标准') %>% 
  kable_styling(bootstrap_options = c('striped', 'hover', 'condensed', 'responsive'))
```

以上乃`30`期总体开奖该率。

#### 40期

```{r}
##40期为标准
n40 <- llply(41:nrow(smppp), function(i) {
  ii <- i - 40
  dx = glm(as.numeric(大小)~总值-1, family=poisson, data=smppp[c(ii:i),]) %>% 
    coef %>% exp
  dx <- dx/sum(1 + dx)
  ds = glm(as.numeric(单双)~总值-1, family=poisson, data=smppp[c(ii:i),]) %>% 
    coef %>% exp
  ds <- ds/sum(1 + ds)
  data.frame(dx, ds) %>% 
    rename(`开大` = dx, `开单` = ds) %>% 
    mutate(`开小` = 1- `开大`, `开双` = 1- `开单`) %>% 
    select('开大', '开小', '开单', '开双') %>% 
    data.frame(smppp[i,], .)
}) %>% bind_rows %>% as_tibble

n40 %>% 
  kable(caption = '40期为标准') %>% 
  kable_styling(
  bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(seq(1, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#657383') %>% 
  row_spec(seq(2, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#C0C0C0') %>% 
  scroll_box(width = '100%', height = '400px')
```

以上的数据以`40`期移动数据为标准，然后预测第`41`期移动数据的开奖率。

```{r}
n40[c('开大', '开小', '开单', '开双')] %>% 
  colMeans %>% t %>% 
  kable(caption = '40期为标准') %>% 
  kable_styling(bootstrap_options = c('striped', 'hover', 'condensed', 'responsive'))
```

以上乃`40`期总体开奖该率。

#### 50期

```{r}
##50期为标准
n50 <- llply(51:nrow(smppp), function(i) {
  ii <- i - 50
  dx = glm(as.numeric(大小)~总值-1, family=poisson, data=smppp[c(ii:i),]) %>% 
    coef %>% exp
  dx <- dx/sum(1 + dx)
  ds = glm(as.numeric(单双)~总值-1, family=poisson, data=smppp[c(ii:i),]) %>% 
    coef %>% exp
  ds <- ds/sum(1 + ds)
  data.frame(dx, ds) %>% 
    rename(`开大` = dx, `开单` = ds) %>% 
    mutate(`开小` = 1- `开大`, `开双` = 1- `开单`) %>% 
    select('开大', '开小', '开单', '开双') %>% 
    data.frame(smppp[i,], .)
}) %>% bind_rows %>% as_tibble

n50 %>% 
  kable(caption = '50期为标准') %>% 
  kable_styling(
  bootstrap_options = c('striped', 'hover', 'condensed', 'responsive')) %>% 
  row_spec(0, bold = TRUE, color = '#FDD017', background = '#3A3B3C') %>% 
  row_spec(seq(1, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#657383') %>% 
  row_spec(seq(2, nrow(md1a.pp), by = 2), color = '#FFFF00', background = '#C0C0C0') %>% 
  scroll_box(width = '100%', height = '400px')
```

以上的数以`50`期移动数据为标准，然后预测第`51`期移动数据的开奖率。

```{r}
n50[c('开大', '开小', '开单', '开双')] %>% 
  colMeans %>% t %>% 
  kable(caption = '50期为标准') %>% 
  kable_styling(bootstrap_options = c('striped', 'hover', 'condensed', 'responsive'))
```

以上乃`50`期总体开奖该率。

### 广义相加泊松模型 (GAM)

### 贝叶斯 (βayesian)

### 隐马尔科夫链 (HMM)

### 长短记忆模型 (LSTM)

### 模型比较

```{r}
md <- list(n760 = n760, 
     n20 = n20[c('开大', '开小', '开单', '开双')] %>% colMeans, 
     n30 = n30[c('开大', '开小', '开单', '开双')] %>% colMeans, 
     n40 = n40[c('开大', '开小', '开单', '开双')] %>% colMeans, 
     n50 = n50[c('开大', '开小', '开单', '开双')] %>% colMeans) %>% bind_rows
md <- data.frame(.id = c('n760', 'n20', 'n30', 'n40', 'n50'), md) %>% as_tibble

md %>% 
  kable(caption = '模型比较') %>% 
  kable_styling(bootstrap_options = c('striped', 'hover', 'condensed', 'responsive'))
```

以上的样本数据显示，`20`期、`30`期、`40`期和`50`期为一个移动数据预测下一期开奖率，结果都是相差不大。

## 盈利模式

<br><br>

# 结论

## 总结

以上总结，会员可以到我们平台通过不同盈利模式挣钱的呢。

```{r eval=FALSE}

## 改进

## https://stackoverflow.com/a/45344291
lib(c('RSelenium', 'rvest', 'wdman', 'webshot', 'decryptr'))

## 网址
## 登录网址
lnk <- 'https://m.a80802.com:8760/login'
## 彩种一栏
lnkcz <- 'https://m.cjezllpcecbm.com/allLottery/?source=lottery'
## 1分快三
lnk1k3 <- 'https://m.cjezllpcecbm.com/history/K3/OG1K3/?source=lottery'
## 3分快三
lnk3k3 <- 'https://m.cjezllpcecbm.com/history/K3/OG3K3/?source=lottery'

#lnk1k3 %>% 
#  read_html %>% 
#  html_nodes(xpath = '//*[@id="scrollContainer"]/div[2]') %>% 
#  html_table()

## 打开隐藏浏览器
pDrv <- phantomjs(port = 4567L, verbose = FALSE)
remDr <- remoteDriver(browserName = 'phantomjs', port = 4567L)
remDr$open(silent = TRUE)

## 浏览网站
remDr$navigate(lnk1k3)

## 输入账号
webElem <- remDr$findElement(using = 'xpath', value = '//*[@id="app"]/div/div[1]/div[3]/div/table/tbody/tr[1]/td[2]/input')
webElem$clickElement()
webElem$sendKeysToElement(list('leiou004', key = 'enter'))

## 输入密码
webElem <- remDr$findElement(using = 'xpath', value = '//*[@id="app"]/div/div[1]/div[3]/div/table/tbody/tr[2]/td[2]/input')
webElem$clickElement()
webElem$sendKeysToElement(list('leiou123', key = 'enter'))

## 验证码
## https://github.com/decryptr/decryptr
## https://rpubs.com/johndharrison/14707
webElem <- remDr$findElement(using = 'xpath', value = '//*[@id="geetest"]/div/div[2]/div[1]/div[3]')
webElem$clickElement()
webElem$sendKeysToElement(list(key = 'enter'))
#webElem$switchToFrame('div.geetest_popup_box')

#if (!require(devtools)) install.packages('devtools')
#devtools::install_github('decryptr/decryptr')

## 开奖记录
webElem <- remDr$findElement(using = 'xpath', value = '//*[@id="lotteryNavBar"]')
webElem$clickElement()
webElem$sendKeysToElement(list('leiou004', key = 'enter'))




##样本数据只是减低投资风险，采集实时数据才能证实有效性。


```

<br><br>

# 附录

## 文书明细

以下乃此文书的文件信息。

- 文集建立日：2022-05-31
- 文集最新更新日：`r today('Asia/Shanghai')`
- `r R.version.string`
- [**rmarkdown**](https://github.com/rstudio/rmarkdown) 程序包版本：`r packageVersion('rmarkdown')`
- 文集版本：0.2.1
- 文集作者：[®γσ, ξηg Lιαη Ημ](https://rpubs.com/englianhu/ryo-cn)
- 猫舍：[源代码](https://github.com/englianhu/report)
- 追加附属信息

```{r info}
#suppressMessages(require('formattable', quietly = TRUE))
#suppressMessages(require('knitr', quietly = TRUE))
#suppressMessages(require('kableExtra', quietly = TRUE))
#suppressMessages(require('magittr', quietly = TRUE))
#suppressMessages(require('devtools', quietly = TRUE))

sys1 <- session_info()$platform |> 
    unlist() |> 
    {\(.) data.frame(row.names = 1:length(.), 
                     Category = names(.), session_info = .)}()

sys2 <- data.frame(Sys.info()) |> 
    {\(.) data.frame(Category = row.names(.), Sys.info = .[,1])}()

#remarks, dim(sys1), dim(sys2)
if (nrow(sys1) == 11 && nrow(sys2) == 8) {
  sys2 <- sys2 |> 
    {\(.) rbind(., data.frame(
    Category = c('rmarkdown', 'rsconnect', 'Current time'), 
    Sys.info = c(as.character(getwd()), 
                 as.character(packageVersion('rsconnect')), 
                 paste(as.character(lubridate::now('Asia/Shanghai')), 'CST 🗺'))))}()
  
} else if (nrow(sys1) == 10 && nrow(sys2) == 8) {
  sys1 <- rbind(sys1, data.frame(Category = '', session_info = ''))
  
  sys2 <- sys2 |> 
    {\(.) rbind(., data.frame(
    Category = c('rmarkdown', 'rsconnect', 'Current time'), 
    Sys.info = c(as.character(getwd()), 
                 as.character(packageVersion('rsconnect')), 
                 paste(as.character(lubridate::now('Asia/Shanghai')), 'CST 🗺'))))}()
}

sys <- cbind(sys1, sys2) |> 
  {\(.) 
    kbl(., caption = 'Additional session information:')}() |> 
  {\(.) 
    kable_styling(., bootstrap_options = c('striped', 'hover', 'condensed', 'responsive'))}() |> 
  {\(.) 
    row_spec(., 0, background = 'DimGrey', color = 'yellow')}() |> 
  {\(.) 
    column_spec(., 1, background = 'CornflowerBlue', color = 'red')}() |> 
  {\(.) 
    column_spec(., 2, background = 'grey', color = 'black')}() |> 
  {\(.) 
    column_spec(., 3, background = 'CornflowerBlue', color = 'blue')}() |> 
  {\(.) 
    column_spec(., 4, background = 'grey', color = 'white')}() |> 
  {\(.) 
    row_spec(., 11, bold = TRUE, color = 'yellow', background = '#D7261E')}()

rm(sys1, sys2)
sys
```

## 参考文献

1) [心理学书籍[第三辑]PDF电子书百度云网盘打包下载](https://www.bluestep.cc/%E5%BF%83%E7%90%86%E5%AD%A6%E4%B9%A6%E7%B1%8D%E7%AC%AC%E4%B8%89%E8%BE%91pdf%E7%94%B5%E5%AD%90%E4%B9%A6%E7%99%BE%E5%BA%A6%E4%BA%91%E7%BD%91%E7%9B%98%E6%89%93%E5%8C%85%E4%B8%8B%E8%BD%BD)
2) [GitHub : Statistical Rethinking (2022 Edition)](https://github.com/englianhu/stat_rethinking_2022)
3) [GitHub : `rethinking` package](https://github.com/englianhu/rethinking) McElreath 2020. Statistical Rethinking, 2nd edition
4) [GitHub : Stan](https://github.com/stan-dev)
5) [GitHub : Repository for distributing (some) stan-dev R packages](https://github.com/stan-dev/r-packages)
6) [书栈网](https://www.bookstack.cn/user/englianhu)
7) [机器学习，关联规则与购物篮分析实战](https://zhuanlan.zhihu.com/p/386763670)
8) [数据挖掘之概率统计(一)](https://zhuanlan.zhihu.com/p/149937711)
9) [数据挖掘算法之-关联规则挖掘(Association Rule)（购物篮分析）](https://blog.csdn.net/goodhuajun/article/details/39893953)
10) [R语言用KERAS长短期记忆LSTM神经网络分类分析问答文本数据](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e7%94%a8keras%e9%95%bf%e7%9f%ad%e6%9c%9f%e8%ae%b0%e5%bf%86lstm%e7%a5%9e%e7%bb%8f%e7%bd%91%e7%bb%9c%e5%88%86%e7%b1%bb%e5%88%86%e6%9e%90%e9%97%ae%e7%ad%94%e6%96%87%e6%9c%ac%e6%95%b0)
11) [数据分享|R语言用Keras长短期记忆LSTM神经网络分类分析问答文本数据](https://mp.weixin.qq.com/s?__biz=MzU4NTA1MDk4MA==&mid=2247515373&idx=1&sn=9e3f528f55990f09dd60e1173acdd87a&chksm=fd9282e6cae50bf04f16d8bc65c5b271fd4018ba0ae911b507131bc560adcb078883f6e52148&token=996621185&lang=zh_CN#rd)
12) [用于NLP的PYTHON：使用KERAS的多标签文本LSTM神经网络分类](http://tecdat.cn/%e7%94%a8%e4%ba%8enlp%e7%9a%84python%ef%bc%9a%e4%bd%bf%e7%94%a8keras%e7%9a%84%e5%a4%9a%e6%a0%87%e7%ad%be%e6%96%87%e6%9c%aclstm%e7%a5%9e%e7%bb%8f%e7%bd%91%e7%bb%9c%e5%88%86%e7%b1%bb)
13) [618网购数据盘点——剁手族在关注什么？](http://tecdat.cn/618%e7%bd%91%e8%b4%ad%e6%95%b0%e6%8d%ae%e7%9b%98%e7%82%b9-%e5%89%81%e6%89%8b%e6%97%8f%e5%9c%a8%e5%85%b3%e6%b3%a8%e4%bb%80%e4%b9%88%ef%bc%9f)
14) [PYTHON中利用长短期记忆模型LSTM进行时间序列预测分析 – 预测电力负荷数据](http://tecdat.cn/python%e4%b8%ad%e5%88%a9%e7%94%a8%e9%95%bf%e7%9f%ad%e6%9c%9f%e8%ae%b0%e5%bf%86%e6%a8%a1%e5%9e%8blstm%e8%bf%9b%e8%a1%8c%e6%97%b6%e9%97%b4%e5%ba%8f%e5%88%97%e9%a2%84%e6%b5%8b%e5%88%86%e6%9e%90)
15) [PYTHON在KERAS中使用LSTM解决序列问题](http://tecdat.cn/python%e5%9c%a8keras%e4%b8%ad%e4%bd%bf%e7%94%a8lstm%e8%a7%a3%e5%86%b3%e5%ba%8f%e5%88%97%e9%97%ae%e9%a2%98)
16) [PYTHON中用PYTORCH机器学习神经网络分类预测银行客户流失模型](http://tecdat.cn/python%e4%b8%ad%e7%94%a8pytorch%e6%9c%ba%e5%99%a8%e5%ad%a6%e4%b9%a0%e5%88%86%e7%b1%bb%e9%a2%84%e6%b5%8b%e9%93%b6%e8%a1%8c%e5%ae%a2%e6%88%b7%e6%b5%81%e5%a4%b1%e6%a8%a1%e5%9e%8b)
17) [用R语言实现神经网络预测股票实例](http://tecdat.cn/%e7%94%a8r%e8%af%ad%e8%a8%80%e5%ae%9e%e7%8e%b0%e7%a5%9e%e7%bb%8f%e7%bd%91%e7%bb%9c%e9%a2%84%e6%b5%8b%e8%82%a1%e7%a5%a8%e5%ae%9e%e4%be%8b)
18) [MATLAB使用贝叶斯优化的深度学习：卷积神经网络CNN](http://tecdat.cn/matlab%e4%bd%bf%e7%94%a8%e8%b4%9d%e5%8f%b6%e6%96%af%e4%bc%98%e5%8c%96%e7%9a%84%e6%b7%b1%e5%ba%a6%e5%ad%a6%e4%b9%a0)
19) [R语言多元COPULA GARCH 模型时间序列预测](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e5%a4%9a%e5%85%83copula-garch-%e6%a8%a1%e5%9e%8b%e6%97%b6%e9%97%b4%e5%ba%8f%e5%88%97%e9%a2%84%e6%b5%8b)
20) [【稀土掘金】R语言用Keras长短期记忆LSTM神经网络分类分析问答文本数据](https://juejin.cn/post/7100020082050498597)
21) [在R语言中使用GAM（广义相加模型）进行电力负荷时间序列分析](http://tecdat.cn/%e5%9c%a8r%e8%af%ad%e8%a8%80%e4%b8%ad%e4%bd%bf%e7%94%a8gam%ef%bc%88%e5%b9%bf%e4%b9%89%e7%9b%b8%e5%8a%a0%e6%a8%a1%e5%9e%8b%ef%bc%89%e8%bf%9b%e8%a1%8c%e7%94%b5%e5%8a%9b%e8%b4%9f%e8%8d%b7%e6%97%b6)
22) [R语言中ARMA，ARIMA（BOX-JENKINS），SARIMA和ARIMAX模型用于预测时间序列数据](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e4%b8%adarma%ef%bc%8carima%ef%bc%88box-jenkins%ef%bc%89%ef%bc%8csarima%e5%92%8carimax%e6%a8%a1%e5%9e%8b%e7%94%a8%e4%ba%8e%e9%a2%84%e6%b5%8b%e6%97%b6%e9%97%b4%e5%ba%8f%e5%88%97)
23) [R语言估计时变VAR模型时间序列的实证研究分析案例](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e4%bc%b0%e8%ae%a1%e6%97%b6%e5%8f%98var%e6%a8%a1%e5%9e%8b%e6%97%b6%e9%97%b4%e5%ba%8f%e5%88%97%e7%9a%84%e5%ae%9e%e8%af%81%e7%a0%94%e7%a9%b6%e5%88%86%e6%9e%90%e6%a1%88%e4%be%8b)
24) [R语言隐马尔可夫模型HMM连续序列重要性重抽样CSIR估计随机波动率模型SV分析股票收益率时间序列](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e9%9a%90%e9%a9%ac%e5%b0%94%e5%8f%af%e5%a4%ab%e6%a8%a1%e5%9e%8bhmm%e8%bf%9e%e7%bb%ad%e5%ba%8f%e5%88%97%e9%87%8d%e8%a6%81%e6%80%a7%e9%87%8d%e6%8a%bd%e6%a0%b7csir%e4%bc%b0%e8%ae%a1)
25) [R语言中的STAN概率编程MCMC采样的贝叶斯模型](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e4%b8%ad%e7%9a%84stan%e6%a6%82%e7%8e%87%e7%bc%96%e7%a8%8bmcmc%e9%87%87%e6%a0%b7%e7%9a%84%e8%b4%9d%e5%8f%b6%e6%96%af%e6%a8%a1%e5%9e%8b)
26) [R语言使用贝叶斯层次模型进行空间数据分析](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e4%bd%bf%e7%94%a8%e8%b4%9d%e5%8f%b6%e6%96%af%e5%b1%82%e6%ac%a1%e6%a8%a1%e5%9e%8b%e8%bf%9b%e8%a1%8c%e7%a9%ba%e9%97%b4%e6%95%b0%e6%8d%ae%e5%88%86%e6%9e%90)
27) [R语言实现向量自回归VAR模型](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e5%ae%9e%e7%8e%b0%e5%90%91%e9%87%8f%e8%87%aa%e5%8a%a8%e5%9b%9e%e5%bd%92var%e6%a8%a1%e5%9e%8b)
28) [一文搞懂HMM（隐马尔可夫模型）](https://www.cnblogs.com/skyme/p/4651331.html)
29) [马尔可夫链观点下的电商网站](http://meroa.com/markov-chain-shopping-guide)
30) [R语言多元LOGISTIC逻辑回归 应用案例](http://tecdat.cn/r%e8%af%ad%e8%a8%80%e5%a4%9a%e5%85%83logistic%e9%80%bb%e8%be%91%e5%9b%9e%e5%bd%92-%e5%ba%94%e7%94%a8%e6%a1%88%e4%be%8b)
31) [不同用户生命周期的运营策略](https://www.jianshu.com/p/c03b6f8aeee9)
32) []()
33) []()
34) []()
35) []()
36) []()
37) []()
38) []()
39) []()
40) []()

---

[<img src="文艺坊图库/Scibrokes.png" height="14"/> Sςιβrοκεrs Trαdιηg®](http://www.scibrokes.com)<br>
<span style='color:RoyalBlue'>**[<img src="文艺坊图库/Scibrokes.png" height="14"/> 世博量化®](http://www.scibrokes.com)企业知识产权及版权所有，盗版必究。**</span>