Advertisement
sesquiipedalian

Untitled

Oct 24th, 2023
1,294
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
R 6.70 KB | None | 0 0
  1.  
  2. ```{r}
  3. # ЧАСТЬ 5. Оценка порядковой пробит-модели
  4. model <- polr(as.factor(sub_type) ~ income + age + internet + series + health + male +
  5.               marriage + residence + cat + news + TV + time, data = data, Hess = TRUE)
  6.  
  7. # Посмотрим на результаты
  8. print(model)
  9. ```
  10. ```{r}
  11. # Выбор случайных значений для каждого признака
  12. individual <- data[sample(nrow(data), 1), -c(11,12)]
  13.  
  14. # Прогнозирование вероятностей
  15. predicted_probs <- predict(model, newdata=individual, type="probs")
  16.  
  17. # Вероятность для обычной подписки
  18. prob_ordinary <- predicted_probs[2]
  19. print(prob_ordinary)
  20. ```
  21.  
  22.  
  23. ```{r}
  24. # Оценка порядковой пробит-модели
  25. model <- polr(as.factor(sub_type) ~ income + age + internet + series + health + male +
  26.     marriage + residence + cat + news + TV + time, data=data, Hess=TRUE)
  27. ```
  28.  
  29.  
  30. ```{r}
  31. # Коэффициенты из вашей порядковой пробит-модели
  32. coef <- c(income = 2.084015e-05, age = 1.471304e-02, internet = 1.627123e+00, series = 2.306277e-01,
  33.           healthgood = 5.127466e-01, healthmedium = 3.337718e-02, male = 3.443925e+00, marriage = -4.772577e-02,
  34.           residenceCity = -6.251955e-01, residenceVillage = -2.100985e+00, cat = -9.918646e-03,
  35.           news = 7.752378e-02, TV = -2.171019e+00, time = -4.459438e-04)
  36.  
  37. # Предельные эффекты  
  38. effects <- coef / (1 + exp(-coef))
  39.  
  40. # Вывод результатов
  41. effects
  42. ```
  43.  
  44. ```{r}
  45. # Создание дамми-переменных
  46. data$healthgood <- as.numeric(data$health == "good")
  47. data$healthmedium <- as.numeric(data$health == "medium")
  48. data$residenceCity <- as.numeric(data$residence == "City")
  49. data$residenceVillage <- as.numeric(data$residence == "Village")
  50.  
  51. # Выбор случайного индивида из данных
  52. random_individual <- data[sample(nrow(data), 1),]
  53.  
  54. # Коэффициенты из вашей порядковой пробит-модели
  55. coef <- c(income = 2.084015e-05, age = 1.471304e-02, internet = 1.627123e+00, series = 2.306277e-01,
  56.           healthgood = 5.127466e-01, healthmedium = 3.337718e-02, male = 3.443925e+00, marriage = -4.772577e-02,
  57.           residenceCity = -6.251955e-01, residenceVillage = -2.100985e+00, cat = -9.918646e-03,
  58.           news = 7.752378e-02, TV = -2.171019e+00, time = -4.459438e-04)
  59.  
  60. # Предельные эффекты для непрерывных переменных
  61. continuous_effects <- coef / (1 + exp(-coef))
  62.  
  63. # Предельные эффекты для дискретных переменных
  64. discrete_vars <- c("male", "marriage", "residenceCity", "residenceVillage", "cat", "TV", "healthgood", "healthmedium")
  65. discrete_effects <- numeric(length(discrete_vars))
  66. for (i in 1:length(discrete_vars)) {
  67.     x0 <- as.numeric(random_individual[, names(coef)])
  68.     x1 <- x0
  69.     x1[which(names(coef) == discrete_vars[i])] <- 1 - x0[which(names(coef) == discrete_vars[i])]
  70.     prob_x0 <- pnorm(sum(coef * x0))
  71.     prob_x1 <- pnorm(sum(coef * x1))
  72.     discrete_effects[i] <- prob_x1 - prob_x0
  73. }
  74. names(discrete_effects) <- discrete_vars
  75.  
  76. # Вывод результатов
  77. list(Continuous = continuous_effects, Discrete = discrete_effects)
  78. ```
  79. ```{r}
  80. # Полная модель
  81. full_model <- polr(as.factor(sub_type) ~ income + age + internet + series + health + male + marriage + residence + cat + news + TV + time, data = data)
  82.  
  83. # Ограниченная модель (предположим, мы хотим сравнить коэффициенты для переменных 'income' и 'age')
  84. data$combined_var <- data$income + data$age
  85. restricted_model <- polr(as.factor(sub_type) ~ combined_var + internet + series + health + male + marriage + residence + cat + news + TV + time, data = data)
  86.  
  87. # LR статистика
  88. lr_stat <- -2 * (logLik(restricted_model) - logLik(full_model))
  89.  
  90. # P-значение
  91. p_value <- 1 - pchisq(lr_stat, df = 1)
  92.  
  93. print(lr_stat)
  94. ```
  95. ```{r}
  96. print(p_value)
  97. ```
  98. <!-- ЧАСТЬ 6 -->
  99. ```{r}
  100. library(nnet)
  101. # Оценка мультиномиальной логит-модели
  102. mnl_model <- multinom(sub_type ~ income + age + internet + series + health + male + marriage + residence + cat + news + TV + time, data = data)
  103.  
  104. # Вывод результатов
  105. print(mnl_model)
  106. ```
  107. ```{r}
  108.  
  109. # Выбор случайных значений для каждого признака
  110. individual <- data[sample(nrow(data), 1),]
  111. print(individual)
  112. # Применение модели к данным индивида
  113. predicted_probs <- predict(mnl_model, newdata = individual, type = "probs")
  114.  
  115. # Вероятность выбора обычной подписки
  116. ans <- predicted_probs[2]
  117.  
  118. print(ans)
  119.  
  120. ```
  121.  
  122. ```{r}
  123. # Выбор случайного индивида из данных
  124. random_individual <- data[sample(nrow(data), 1),]
  125.  
  126. # Предельные эффекты для непрерывных переменных
  127. continuous_vars <- c("income", "age", "internet", "series")
  128. continuous_effects <- numeric(length(continuous_vars))
  129. predicted_probs <- predict(mnl_model, newdata = random_individual, type = "probs")
  130. print(names(coef))
  131. for (i in 1:length(continuous_vars)) {
  132.     beta_k <- coef[continuous_vars[i]] # обновленное извлечение коэффициентов
  133.     prob_k <- predicted_probs[2]
  134.     prob_0 <- predicted_probs[1]
  135.     continuous_effects[i] <- (beta_k * prob_k) - (0 * prob_0) # 0 для базовой категории
  136. }
  137.  
  138. # Предельные эффекты для дискретных переменных
  139. discrete_vars <- c("male", "marriage", "residenceCity", "residenceVillage", "cat", "TV", "healthgood", "healthmedium")
  140. discrete_effects <- numeric(length(discrete_vars))
  141. for (i in 1:length(discrete_vars)) {
  142.     x0 <- as.numeric(random_individual[, discrete_vars[i]])
  143.     x1 <- 1 - x0
  144.     random_individual[, discrete_vars[i]] <- x1
  145.     prob_x1 <- predict(mnl_model, newdata = random_individual, type = "probs")[2]
  146.     discrete_effects[i] <- prob_x1 - prob_k
  147. }
  148.  
  149. # Вывод результатов
  150. list(Continuous = setNames(continuous_effects, continuous_vars),
  151.      Discrete = setNames(discrete_effects, discrete_vars))
  152. ```
  153.  
  154.  
  155. ```{r}
  156. install.packages("sampleSelection")
  157.  
  158. # Оценка модели Хекмана
  159. result <- heckit(subscription ~ age + income + education,  # Уравнение участия
  160.                  watch_time ~ age + income,                # Уравнение результата
  161.                  data = your_data_frame)
  162.  
  163. # Печать результатов
  164. summary(result)
  165. ```
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement