25/04/30 08:12:39.62 wedVH8wl.net
# Find data where the overall Chi-squared test is not significant (p > alpha),
# but at least one pairwise proportion test (with Bonferroni correction) is significant (p <= alpha).
res_no_overall_sig_pairwise_sig <- NULL
while (is.null(res_no_overall_sig_pairwise_sig) || res_no_overall_sig_pairwise_sig$chisq_pg > alpha || res_no_overall_sig_pairwise_sig$min_pairwise_p_bonf > alpha) {
res_no_overall_sig_pairwise_sig <- sim_chisq() # Keep simulating until the condition is met.
}
cat("Data where overall Chi-squared test is not significant, but pairwise proportion test is:\n")
print(res_no_overall_sig_pairwise_sig)
cat("\n")
# Find data where the overall Chi-squared test is significant (p <= alpha),
# but all pairwise proportion tests (with Bonferroni correction) are not significant (p > alpha).
res_overall_sig_no_pairwise_sig <- NULL
while (is.null(res_overall_sig_no_pairwise_sig) || res_overall_sig_no_pairwise_sig$chisq_pg < alpha || res_overall_sig_no_pairwise_sig$min_pairwise_p_bonf < alpha) {
res_overall_sig_no_pairwise_sig <- sim_chisq() # Keep simulating until the condition is met.
}
cat("Data where overall Chi-squared test is significant, but pairwise proportion test is not:\n")
print(res_overall_sig_no_pairwise_sig)
options(warn = 0)
851:１３２人目の素数さん
25/04/30 08:13:09.55 wedVH8wl.net
コメントが長すぎて読みにくくなった。
852:１３２人目の素数さん
25/04/30 08:38:32.10 IZhDMqNd.net
>>810
アンタ日本語も読めないからfランですらないねw
あと高校生が解く証明問題すら解けないのに医者東大卒なわけねーだろタコ
853:１３２人目の素数さん
25/05/01 09:07:57.06 L1qIlz9/.net
ディリクレ事前分布のパラメータαを階層化することで、より信頼性の高いベイズ推定が可能となる。
特にこの問題のように「実際に歪んでいる可能性がある」かつ「繰り返しが少ない」ケースでは、階層ベイズモデルはより適切な枠組みです。
854:１３２人目の素数さん
25/05/01 09:09:32.28 L1qIlz9/.net
Stanで作ったらコンパイルに時間がかかる。簡単なモデルはJAGSの方がいい。離散変数も扱えるし。
# JAGS model
library(rjags)
# Prepare the data
outcome_data <- c(rep(1, 17), rep(2, 21), rep(3, 15), rep(4, 21), rep(5, 20), rep(6, 6))
N <- length(outcome_data)
data_jags <- list(outcome = outcome_data, N = N)
# Initial values (adjust as needed)
inits_jags <- list(
list(alpha = rep(1, 6), eta = 1),
list(alpha = runif(6, 0.1, 2), eta = 5)
)
# Compile the model
model_jags <- jags.model(
file = "hierarchical_dice_model.jag",
855:data = data_jags, n.chains = 2, n.adapt = 1000 ) # Sampling samples_jags <- coda.samples( model = model_jags, variable.names = c("prob_simplex", "alpha", "eta"), n.iter = 4000 ) # Summary of the results cat("\nJAGS Sampling Results Summary:\n") summary(samples_jags) # Extract posterior samples (prob_simplex) prob_simplex_posterior_jags <- as.matrix(samples_jags[, grep("prob_simplex", varnames(samples_jags))]) head(prob_simplex_posterior_jags) # Plotting (example: posterior distribution of probabilities for each outcome) cat("\nPosterior Distribution Plots for Each Outcome:\n") par(mfrow = c(2, 3)) for (i in 1:6) { plot(prob_simplex_posterior_jags[, i], type = "l", main = paste("Prob[", i, "]"), xlab = "Iteration", ylab = "Probability") abline(h = 1/6, col = "red", lty = 2) } dice_prob_mean=prob_simplex_posterior_jags colors <- c("skyblue", "lightcoral", "lightgreen", "gold", "lightsalmon", "lightcyan") for (i in 1:ncol(dice_prob_mean)) { BEST::plotPost(dice_prob_mean[, i], compVal=1/6, xlab=paste("pip ", i), xlim=c(0, 0.4), main="", col=colors[i], border="black") }
856:１３２人目の素数さん
25/05/01 09:14:13.25 L1qIlz9/.net
事後分布が出せたのであとはオッズ比などの計算も容易。
URLﾘﾝｸ(i.imgur.com)
857:１３２人目の素数さん
25/05/01 11:18:32.55 L1qIlz9/.net
ニッチな値の探索処理が終了しないコード
rm(list=ls())
library(fmsb)
library(parallel)
alpha <- 0.05
# Function to perform a single simulation
sim_single <- function(N = 100) {
A <- sample(1:N, 1)
while (A > N - 2) A <- sample(1:N, 1)
B <- sample(N - A - 1, 1)
C <- N - A - B
ABC <- c(A, B, C)
abc <- sapply(ABC, function(x) sample(x, 1))
x <- abc
n <- ABC
m <- rbind(s = x, f = n - x)
bonf_res <- pairwise.fisher.test(x, n, p.adj = 'bonf')
holm_res <- pairwise.fisher.test(x, n, p.adj = 'holm')
fdr_res <- pairwise.fisher.test(x, n, p.adj = 'fdr')
none_res <- pairwise.fisher.test(x, n, p.adj = 'none')
bonf <- min(bonf_res$p.value, na.rm = TRUE)
holm <- min(holm_res$p.value, na.rm = TRUE)
fdr <- min(fdr_res$p.value, na.rm = TRUE)
none <- min(none_res$p.value, na.rm = TRUE)
list(m = m, bonf = bonf, holm = holm, fdr = fdr, none = none)
}
# Function to find a result that meets the criteria using parallel processing
find_result_parallel_loop <- function(alpha = 0.05, num_cores = detectCores() - 1) {
# Create a cluster of worker processes
cl <- makeCluster(num_cores)
# Ensure the cluster is stopped when the function exits
on.exit(stopCluster(cl))
# Export the sim_single function to the worker processes
clusterExport(cl, "sim_single")
# Load the fmsb library in the worker processes
clusterEvalQ(cl, library(fmsb))
cat("Searching for a result that meets the criteria...\n")
while (TRUE) {
# Run simulations in parallel
results <- parLapply(cl, 1:num_cores, function(i) { # Run as many simulations as cores
sim_single()
})
# Check the results for the desired condition
for (res in results) {
if (res$bonf > alpha && res$holm < alpha) {
cat("Result meeting the criteria found:\n")
return(res)
}
}
# If no result found in this batch, continue the loop
}
}
# Find the result using parallel processing until found
res_parallel_loop <- find_result_parallel_loop(alpha = alpha)
# Output the result (will be printed within the loop when found)
print(res_parallel_loop)
858:１３２人目の素数さん
25/05/01 19:36:50.50 VtjTJL9d.net
３群以上の多群の比の比較検定で、ペアワイズでの有意差検定を行いボンフェローニ補正ではどのペアでも有意差なしだが、
ホルム補正では有意差がでるペアが存在するというデータを有意水準0.05として作成してください。
各群のサンプルサイズは不均等でもかまいません。
859:１３２人目の素数さん
25/05/01 19:38:55.56 twZ5uJsW.net
質問
860:スレなので宿題依頼スレでやってください
861:１３２人目の素数さん
25/05/01 22:05:28.78 xi2mMyC+.net
またゴミがなんかいってるよ。アホなサイト引っ張りだしてきてでたらめほざいて。正しいこと言ってるサイトと見分けつかんのかね？大学院とかついてたらそれだけで信じるカス。書いてる内容メタくそやん。
862:１３２人目の素数さん
25/05/02 10:48:45.43 +8QO9mMm.net
set.seed(123)
library(fmsb)
alpha <- 0.05
N <- 1000
sim <- function() {
# 群ごとのサンプルサイズ（不均等で可）
n1 <- sample(250:350, 1) # 低用量
n2 <- sample(250:350, 1) # 高用量
n3 <- N - n1 - n2 # プラセボ
# 各群の成功率設定（ペアでは差なし、プラセボ vs 合算で差あり）
p1 <- 0.30 # 低用量
p2 <- 0.31 # 高用量
p3 <- 0.22 # プラセボ（低め）
x1 <- rbinom(1, n1, p1)
x2 <- rbinom(1, n2, p2)
x3 <- rbinom(1, n3, p3)
m <- rbind(success = c(x1, x2, x3), failure = c(n1 - x1, n2 - x2, n3 - x3))
bonf_p <- suppressWarnings(min(as.vector(pairwise.fisher.test(m[1,], colSums(m), p.adj="bonf")$p.value), na.rm=TRUE))
combined <- matrix(c(x1 + x2, n1 + n2 - x1 - x2, x3, n3 - x3), nrow=2)
comb_p <- fisher.test(combined)$p.value
list(m = m, bonf = bonf_p, combined_p = comb_p, sizes = c(n1, n2, n3))
}
# 条件を満たすデータが出るまでループ
res <- sim()
while (!(res$bonf > alpha && res$combined_p < alpha)) {
res <- sim()
}
# 結果出力
res$m
cat("Bonferroni-adjusted pairwise p-value (min):", res$bonf, "\n")
cat("Combined treatment vs placebo p-value:", res$combined_p, "\n")
cat("Sample sizes:", res$sizes, "\n")
863:１３２人目の素数さん
25/05/02 11:02:18.75 +8QO9mMm.net
set.seed(123)
library(fmsb)
alpha <- 0.05
N <- 1000
# Simulation function
sim <- function() {
# Random group sizes
n1 <- sample(250:350, 1) # Low-dose
n2 <- sample(250:350, 1) # High-dose
n3 <- N - n1 - n2 # Placebo
if (n3 < 100) return(NULL) # Skip too-small placebo
# Success rates from uniform distribution
p1 <- runif(1)
p2 <- runif(1)
p3 <- runif(1)
# Binomial draws
x1 <- rbinom(1, n1, p1)
x2 <- rbinom(1, n2, p2)
x3 <- rbinom(1, n3, p3)
# 3-group matrix
m3 <- rbind(success = c(x1, x2, x3),
failure = c(n1 - x1, n2 - x2, n3 - x3))
colnames(m3) <- c("Low", "High", "Placebo")
# Add 4th group = combined (low + high)
x4 <- x1 + x2
n4 <- n1 + n2
m4 <- cbind(m3, Combined = c(x4, n4 - x4))
# Perform pairwise Fisher's exact tests across 4 groups
pw <- suppressWarnings(pairwise.fisher.test(m4[1,], colSums(m4), p.adj="bonf")$p.value)
pw_vals <- as.vector(pw)
pw_vals <- pw_vals[!is.na(pw_vals)]
names_all <- names(pw_vals)
# Identify significant pairs
sig_idx <- which(pw_vals < alpha)
sig_names <- names(pw_vals)[sig_idx]
# Check if only Combined vs Placebo is significant
is_valid <- length(sig_idx) == 1 &&
any(grepl("Placebo-Combined|Combined-Placebo", sig_names))
if (is_valid) {
return(list(m = m4, probs = c(p1, p2, p3), sizes = c(n1, n2, n3), pvals = pw))
} else {
return(NULL)
}
}
# Run until condition met
res <- NULL
while (is.null(res)) {
res <- sim()
}
# Output results
print(res$m)
cat("Success probabilities (Low, High, Placebo):", round(res$probs, 3), "\n")
cat("Sample sizes (Low, High, Placebo):", res$sizes, "\n")
cat("Pairwise Bonferroni-adjusted p-values:\n")
print(res$pvals)
864:１３２人目の素数さん
25/05/02 22:44:37.00 056ygUN9.net
EMPAREG試験の解析をベイズでやっていたら、低用量高用量を統合する必要もなかったはず。
頻度主義統計で有意差がでない237:253の範囲でもプラセボよりイベント発生を抑制することが示せる。
############## 237:253 ################
# JAGSモデル文字列
model_string <- "
model {
for (i in 1:N) {
s[i] ~ dbin(theta[i], n[i]) # n[i] を別に与える
theta[i] ~ dbeta(1, 1) # 非情報的事前分布
}
}
"
EMPA_REG=\(x,verb
865:ose=FALSE){ # データ data_list <- list( s = c(288, x, 490-x), n = c(2333, 2345, 2342), N = 3 ) # 初期値 # init_fun <- function() list(theta = runif(3, 0.05, 0.15)) init_fun <- function() list(theta = runif(3)) # モデル構築・初期化・実行 library(rjags) model <- jags.model(textConnection(model_string), data = data_list, inits = init_fun, n.chains = 3, n.adapt = 1000) # バーンインとサンプル取得 update(model, 1000) samples <- coda.samples(model, variable.names = c("theta"), n.iter = 5000) ms=as.matrix(samples) Placebo=ms[,1] Low=ms[,2] High=ms[,3] if(verbose){ ylim=c(0,max(max(density(Placebo)$y), max(density(Low)$y), max(density(High)$y))) xu=max(max(density(Placebo)$x), max(density(Low)$x), max(density(High)$x)) xl=min(min(density(Placebo)$x), min(density(Low)$x), min(density(High)$x)) xlim=c(xl,xu) plot(density(Placebo),xlim=xlim,ylim=ylim,xlab=quote(theta),ylab='',main='',col=8) lines(density(Low),col='pink',lwd=2) lines(density(High),col='red',lwd=2) } c(Low_Effective=mean(Low<Placebo),High_Effective=mean(High<Placebo) ) } ans=sapply(237:253,EMPA_REG) ans
866:１３２人目の素数さん
25/05/04 19:45:41.87 Ie2Wyhjx.net
CRANからパッケージBESTが消えていたのでplotPostと同等機能の関数を復刻（不適当データ入力などエラー回避処理は面倒なのでやってない）。
URLﾘﾝｸ(i.imgur.com)
This function helps visualize posterior distribution samples from Bayesian inference and displays various informative elements. It can show the mean, mode, median, a credible interval (either HDI or quantiles), the Region of Practical Equivalence (ROPE), and a comparison value.
Arguments:
posterior_samples: A numeric vector of posterior distribution samples.
credMass: The width of the credible interval (a numeric value between 0 and 1; default is 0.95).
ROPE: A numeric vector specifying the ROPE range (e.g., c(lower_bound, upper_bound)).
compVal: A numeric value for comparison.
showMean: A logical value indicating whether to display the mean (TRUE/FALSE).
showMode: A logical value indicating whether to display the mode (TRUE/FALSE).
showMedian: A logical value indicating whether to display the median (TRUE/FALSE).
showCurve: A logical value indicating whether to display a density plot (TRUE/FALSE; if FALSE, a histogram is shown).
showQuantile: A logical value indicating whether to display the credible interval as quantiles instead of HDI (TRUE/FALSE).
xlab: The label for the x-axis.
main: The title of the plot.
hist_color: The color of the histogram.
textSize: The size of the text elements.
yaxt: The y-axis style (default is to show only numbers).
...: Additional arguments to be passed to the plotting function.
867:１３２人目の素数さん
25/05/05 19:07:36.02 LDY1RQtT.net
# This R function, riskratio.boot, calculates the risk ratio and its Highest Density Interval (HDI)
# using a bootstrap method. It takes the number of events and the total number of observations
# for two groups as input.
riskratio.boot <- function(r1, r2, n1, n2, nboot = 5000, conf.level = 0.95, verbose = FALSE){
# Combine the number of events and total observations for both groups.
r <- c(r1, r2)
n <- c(n1, n2)
# Create a 2x2 matrix representing the contingency table (number of events and non-events).
m <- cbind(r, n - r) ; m
# Perform bootstrap resampling to estimate the risk ratio distribution.
rr <- replicate(nboot, {
# Simulate the number of events in the first group by sampling with replacement
# from a population with the observed event rate.
sample(c(rep(1, r1), rep(0, n1 - r1)), n1, replace = TRUE) |> sum() -> R1
# Simulate the number of events in the second group similarly.
sample(c(rep(1, r2), rep(0, n2 - r2)), n2, replace = TRUE) |> sum() -> R2
# Calculate the risk ratio from the bootstrapped event counts.
(R1 / n1) / (R2 / n2)
})
# If verbose is TRUE, plot the posterior distribution of the risk ratio.
if(verbose){
source('plotpost.R') # Assuming 'plotpost.R' is a script for plotting posterior distributions.
plotpost(rr, compVal = 1, showCurve = 1, lwd = 4) # Plot the distribution with a comparison value of 1.
}
# Calculate the mean of the bootstrapped risk ratios.
b_mean <- mean(rr)
# Calculate the Highest Density Interval (HDI) of the bootstrapped risk ratios.
b_ci <- HDInterval::hdi(rr, credMass = conf.level)
# Return a list containing the bootstrap mean and the HDI.
list(b_mean = b_mean, b_ci = b_ci)
}
# Example usage of the riskratio.boot function.
riskratio.boot(244, 282, 2345, 2333)
868:１３２人目の素数さん
25/05/05 19:08:42.51 LDY1RQtT.net
Description:
The `riskratio.boot` function in R estimates the risk ratio between two groups and provides its Highest Density Interval (HDI) using a bootstrap resampling approach. It takes the counts of events and the total number of observations for each of the two groups as input.
Usage:
riskratio.boot(r1, r2, n1, n2, nboot = 5000, conf.level = 0.95, verbose = FALSE)
Arguments:
* `r1`: The number of events in the first group.
* `r2`: The number of events in the second group.
* `n1`: The total number of observations in the first group.
* `n2`: The total number of observations in the second group.
* `nboot`: The number of bootstrap replicates to perform (default is 5000). A larger number of replicates generally provides more stable estimates.
* `conf.level`: The credibility level for the Highest Density Interval (HDI) (default is 0.95, corresponding to a 95% HDI).
* `verbose`: A logical value indicating whether to display a plot of the bootstrap distribution of the risk ratio (default is `FALSE`). If `TRUE`, it assumes a script named `plotpost.R` is available in the working directory for plotting.
869:１３２人目の素数さん
25/05/05 19:09:02.55 LDY1RQtT.net
Details:
The function works by simulating the event outcomes in each group through bootstrap resampling. For each group, it draws `n1` (or `n2`) samples with replacement from a hypothetical population that has the observed proportion of events (`r1/n1` or `r2/n2`). The number of events in each resampled set (`R1` and `R2`) is then used to calculate a bootstrapped risk ratio `(R1/n1) / (R2/n2)`. This process is repeated `nboot` times to generate a distribution of risk ratios. The function then calculates the mean of this distribution and its Highest Density Interval (HDI), which represents the most credible range for the true risk ratio given the data and the bootstrap procedure.
If `verbose` is set to `TRUE`, the function attempts to plot the distribution of the bootstrapped risk ratios using a script named `plotpost.R`. This requires that the `plotpost.R` script exists in the current working directory and is capable of handling the vector of bootstrapped risk ratios.
Value:
The function returns a list with the following components:
* `b_mean`: The mean of the bootstrapped risk ratios.
* `b_ci`: The Highest Density Interval (HDI) of the bootstrapped risk ratios, as a vector with the lower and upper bounds.
Note:
The `verbose = TRUE` option depends on an external script `plotpost.R`. If you intend to use this option, ensure that the script is available and correctly implemented for plotting posterior-like distributions. The HDI is calculated using the `hdi` function from the `HDInterval` package, so this package must be installed (`install.packages("HDInterval")`) and loaded (`library(HDInterval)`) if you intend to use the default behavior.
870:１３２人目の素数さん
25/05/05 19:23:25.28 LDY1RQtT.net
> riskratio.boot(244,282,2345,2333,nboot=10000)
$b_mean
[1] 0.8641319
$b_ci
lower upper
0.7312212 1.0106121
attr(,"credMass")
[1] 0.95
871:１３２人目の素数さん
25/05/09 06:19:21.94 vIVXuysf.net
SequentialPrimeDigits[n_Integer] :=
Module[{p = 10, result = {}},
While[Length[result] < n,
If[PrimeQ[p] && AllDifferencesAreOneQ[p],
AppendTo[result, p]
];
p++
];
result
]
AllDifferencesAreOneQ[num_Integer] :=
Differences[IntegerDigits[num]] === ConstantArray[1, Length[IntegerDigits[num]] - 1]
SequentialPrimeDigits[5]
{23, 67, 89, 4567, 23456789}
SequentialPrimeDigits[20]
872:１３２人目の素数さん
25/05/10 11:02:46.60 ynDPH7B8.net
# ------------------------------------------------------------------------------
# ファイル名：logistic_regression_uraguchi_factors.R
# 目的：裏口入学の決定要因を評価するロジスティック回帰分析
# 考察対象の説明変数：学力、大学ランク (基準カテゴリ: A)、縁故、親の所得、寄付金
# ------------------------------------------------------------------------------
# データ生成 (大学ランクを因子型、基準レベル A)
set.seed(123)
n <- 1000
ranks_char <- sample(LETTERS[1:6], n, replace = TRUE)
ranks_factor <- factor(ranks_char, levels = LETTERS[1:6], ordered = TRUE) # 順序付きファクターとして生成
data <- data.frame(
裏口入学 = rbinom(n, 1, 0.2),
学力 = rnorm(n, mean = 50, sd = 10),
大学ランク = ranks_factor,
縁故 = rbinom(n, 1, 0.1),
親の所得 = rlnorm(n, meanlog = log(5000), sdlog = 0.3),
寄付金 = rlnorm(n, meanlog = log(100000), sdlog = 1.0)
)
# 支払額の生成
rank_numeric <- as.numeric(data$大学ランク) # A=1, B=2, ... 6
data$支払額 <- 10 * pmax(
300 + 100 * data$裏口入学 +
0.5 * (100 - data$学力) +
20 * rank_numeric +
50 * data$縁故 +
0.05 * data$親の所得 +
0.001 * data$寄付金 +
rnorm(n, mean = 0, sd = 50),
0
)
# ロジスティック回帰モデル (大学ランクが因子型として扱われ、基準カテゴリは A)
model_full <- glm(裏口入学 ~ 学力 + 大学ランク + 縁故 + 親の所得 + 寄付金, data = data, family = binomial)
# オッズ比と信頼区間の算出
confint_vals <- exp(confint(model_full))
odds_ratios_ci <- data.frame(
Variable = rownames(confint_vals)[-1],
CI_lower = confint_vals[-1, 1],
CI_upper = confint_vals[-1, 2]
)
# プロット用の変数ラベルを日本語化
label_map <- c(
"学力" = "学力",
"大学ランク.L" = "大学ランク B",
"大学ランク.Q" = "大学ランク C",
"大学ランク.C" = "大学ランク D",
"大学ランク^4" = "大学ランク E",
"大学ランク^5" = "大学ランク F",
"縁故" = "縁故",
"親の所得" = "親の所得",
"寄付金" = "寄付金"
)
odds_ratios_ci$日本語変数名 <- ifelse(odds_ratios_ci$Variable %in% names(label_map),
label_map[odds_ratios_ci$Variable],
odds_ratios_ci$Variable)
873:１３２人目の素数さん
25/05/10 11:02:56.88 ynDPH7B8.net
# 現在の par() の設定を保存
current_par <- par(no.readonly = TRUE)
# 指定された mar と bty で描画
par(mar = c(5, 8, 5, 2), bty = 'l')
# plot 関数を使用したオッズ比の信頼区間プロット (1を基準)
n_vars <- nrow(odds_ratios_ci)
y_positions <- n_vars:1
xlim_odds <- range(odds_ratios_ci$CI_lower, odds_ratios_ci$CI_upper)
plot(NA, xlim = xlim_odds,
ylim = c(0.5, n_vars + 0.5),
xlab = "オッズ比 (log scale)",
ylab = "",
main = "ロジスティック回帰分析：オッズ比の95%信頼区間",
log = "x",
yaxt = "n")
segments(x0 = odds_ratios_ci$CI_lower,
x1 = odds_ratios_ci$CI_upper,
y0 = y_positions,
y1 = y_positions,
col = "skyblue",
lwd = 4)
abline(v = 1, lty = "dashed", col = "black")
# y軸のラベルを日本語で追加
axis(side = 2, at = y_positions, labels = odds_ratios_ci$日本語変数名
874:[order(y_positions, decreasing = TRUE)], las = 1) # 描画後に元の par() の設定に戻す par(current_par)
875:１３２人目の素数さん
25/05/11 21:13:09.76 2CgV4g4d.net
# データ設定
n_placebo <- 1000; eff_placebo <- 24
n_old <- 1000; eff_old <- 40
n_new <- 1000; eff_new <- 25
# 有効率
p_placebo <- eff_placebo / n_placebo
p_old <- eff_old / n_old
p_new <- eff_new / n_new
# 比較：旧薬 vs 偽薬（有意差）
m1 <- matrix(c(eff_old, n_old - eff_old, eff_placebo, n_placebo - eff_placebo), nrow = 2)
test1 <- prop.test(m1, correct = FALSE)
# 比較：新薬 vs 偽薬（有意差なし）
m2 <- matrix(c(eff_new, n_new - eff_new, eff_placebo, n_placebo - eff_placebo), nrow = 2)
test2 <- prop.test(m2, correct = FALSE)
# 比較：旧薬 vs 新薬（非劣性検定）
# 非劣性マージン
M <- -0.10
# 差（新薬 - 旧薬）
diff <- p_new - p_old
# 標準誤差（差の95%信頼区間に使用）
se <- sqrt(p_new*(1 - p_new)/n_new + p_old*(1 - p_old)/n_old)
z <- qnorm(0.025, lower.tail = FALSE)
lower_CI <- diff - z * se
# 非劣性判定
non_inferior <- lower_CI > M
# 結果表示
cat("=== 旧薬 vs 偽薬 ===\n")
print(test1)
cat("\n=== 新薬 vs 偽薬 ===\n")
print(test2)
cat("\n=== 非劣性検定（旧薬 vs 新薬） ===\n")
cat(sprintf("差（新薬 - 旧薬） = %.3f\n", diff))
cat(sprintf("95%% CI = [%.3f, %.3f]\n", diff - z*se, diff + z*se))
cat(sprintf("非劣性マージン = %.3f\n", M))
cat(sprintf("非劣性判定: %s\n", ifelse(non_inferior, "非劣性あり", "非劣性なし")))
876:１３２人目の素数さん
25/05/13 13:21:07.90 L+Wotuil.net
ド底辺シリツ医大の三法則を与えたらAIが１２法則まで拡張してくれました。
ド底辺医大の十二箇条 (The Twelve Laws of Do-Teihen Medical School)
第1法則
ド底辺シリツ医大が悪いのではない、本人の頭が悪いんだ。
It is not the bottom medical school but its enrollee that is despicable, which deserves to be called a bona fide moron beyond redemption.
第2法則
ド底辺シリツ医大卒は恥ずかしくて、学校名を皆さま言いません。
The graduates of Do-Teihen are so ashamed that none of them dare to mention their own alma mater they had gone through.
第3法則
ド底辺特殊シリツ医大卒は裏口入学の負い目から裏口馬鹿を暴く人間を偽医者扱いしたがる。
The Do-Teihen graduates are so ashamed of having bought their way into the exclusively bottom-leveled medical school that they tend to call a genuine doctor a charlatan who elucidates their imbecility.
第4法則
ド底辺医大卒は、偏差値や出身校を気にするなと言いながら、自分の子どもには絶対にそんな大学へは行かせたくないと思っている。
While claiming that academic ranking or alma mater does not matter, a Do-Teihen graduate would never let their own child attend such a university.
第5法則
ド底辺医大卒は、裏口入学を否定しない。否定できない。なぜなら、実際に自分がそうだからである。
A Do-Teihen graduate never denies the existence of backdoor admissions—because deep down, they know they were one of them.
第6法則
ド底辺医大は、「差別するな」と叫びながら、偏差値・財力・コネがない者を最もあからさまに差別する。
While crying out against discrimination, Do-Teihen medical schools are the very institutions that blatantly discriminate against those without test scores, wealth, or connections.
877:１３２人目の素数さん
25/05/13 13:21:14.83 L+Wotuil.net
第7法則
ド底辺医大卒は「実力で入った」と言うが、その“実力”の定義を決して口にしない。
A Do-Teihen graduate may claim, “I got in on merit,” but they will never define what that 'merit' actually was.
第8法則
ド底辺医大卒の最大の敵は、同級生ではなく、偏差値という現実である。
The greatest enemy of a Do-Teihen graduate is not their classmates—but the cold, numerical reality of standardized test scores.
第9法則
ド底辺医大では、人格者は浮く。媚びる者とカネ持ちが残る。
In Do-Teihen med schools, the virtuous are outcasts; only flatterers and the wealthy thrive.
第10法則
ド底辺医大に入る者は、嘘をついて入学し、嘘をつき続けて卒業する。
Those who enter Do-Teihen medical schools do so with lies—and graduate by continuing to lie.
第11法則
ド底辺医大卒は、知性を持つ批判者を最も憎む。それは、自分が決してなれない姿だからだ。
Graduates of Do-Teihen reserve their deepest hatred for intelligent critics—because those critics reflect everything they can never become.
第12法則
ド底辺医大は、医者を育てる場ではない。医師免許を与える「通行証発行所」である。
Do-Teihen is not a school to train doctors. It is a toll booth that issues medical licenses for a price.
878:１３２人目の素数さん
25/05/15 15:07:47.91 vFdoSXtm.net
rm(list=ls())
library(PropCIs)
noninferior.pitfall <- function(r0,n0, r1,n1, r2,n2, r3,n3, nim_coef, alpha=0.05, yates=FALSE) {
delta <- (r0/n0 - r1/n1) * nim_coef
if (min(r0, r1, r2, r3) < 5) {
p1 <- fisher.test(matrix(c(r1, n1-r1, r0, n0-r0), 2, 2))$p.value
p2 <- fisher.test(matrix(c(r2, n2-r2, r0, n0-r0), 2, 2))$p.value
ci_upper <- diffscoreci(r2, n2, r3, n3, conf.level=1-2*alpha)$conf.int[2]
} else {
p1 <- prop.test(c(r1, r0), c(n1, n0), correct=yates)$p.value
p2 <- prop.test(c(r2, r0), c(n1, n0), correct=yates)$p.value
ci_upper <- prop.test(c(r2, r1), c(n2, n1), conf.level=1-2*alpha, correct=yates)$conf.int[2]
}
all(
r1 < r0 && p1 < alpha,
p2 > alpha,
ci_upper < delta
)
}
noninferior.pitfall(16,201,6,202,7,203,6,204,0.684)
879:１３２人目の素数さん
25/05/16 16:37:03.25 s89ybxV8.net
イベント発生が人数比で
臨床試験１で 旧薬 vs プラセボで 5/201 vs 19/202
臨床試験２で 新薬 vs 旧薬 で 9/203 vs 5/204
であったとき
(1) 新薬がプラセボより劣る確率を計算せよ。
(2) 新薬はプラセボより有意差をもって有効といえるか？
計算に必要な条件は適宜設定してよい。
例：イベント発生は独立事象である
library(rjags)
library(coda)
worth_than_placebo <- function(r0, n0, r1, n1, r2, n2, r3, n3){
model_string <- '
model {
# 試験 (旧薬 vs 偽薬)
r1 ~ dbin(p1, n1)
p1 ~ dbeta(1, 1)
r0 ~ dbin(p0, n0)
p0 ~ dbeta(1, 1)
# 試験 (新薬 vs 旧薬)
r2 ~ dbin(p2, n2)
p2 ~ dbeta(1, 1)
r3 ~ dbin(p3, n3)
p3 ~ dbeta(1, 1)
# parameters
p2_est <- p2
p0_est <- p0
p2_worse_than_p0 <- step(p2_est - p0_est)
}
'
data <- list(r1=r1 , n1=n1 , r0=r0 ,n0=n0, r2=r2 , n2=n2 , r3=r3 , n3=n3)
jags_model <- jags.model(file=textConnection(model_string), data=data, n.chains=3,
n.adapt=3000, quiet = TRUE)
update(jags_model, n.iter=2000)
jags_samples <- coda.samples(jags_model, variable.names=c("p2_est", "p0_est", "p2_worse_than_p0"),
n.iter=10000, thin=1)
summary(jags_samples)
js <- as.data.frame(
880:as.matrix(jags_samples)) names(js) source("plotpost.R") layout(matrix(c(1,2,3,3), 2, 2, byrow=TRUE)) plotpost(js$p2_est, col='lightcoral',xlab="新薬",cex.lab=1.5,main="") plotpost(js$p0_est, col='lightgray', xlab="プラセボ",cex.lab=1.5,main="") plotpost(js$p0_est - js$p2_est, compVal = 0, col=c('lightcoral', 'lightgray'), xlab="プラセボ - 新薬", main="",cex.lab=1.5) HDInterval::hdi(js$p0_est - js$p2_est) |> print() mean(js$p2_worse_than_p0) } result <- worth_than_placebo(r0=19, n0=202, r1=5, n1=201, r2=9, n2=203, r3=5, n3=204) print(paste("新薬がプラセボより劣る確率:", result))
881:１３２人目の素数さん
25/05/17 02:21:13.42 zAzyVzie.net
>>839
# --- 必要パッケージ ---
library(rjags)
library(coda)
library(HDInterval)
# --- データ定義 ---
data_list <- list(
r0 = 19, n0 = 202, # プラセボ
r1 = 5, n1 = 201, # 旧薬（試験1）
r2 = 9, n2 = 203, # 新薬
r3 = 5, n3 = 204 # 旧薬（試験2）
)
# --- 階層モデル定義 ---
model_hier <- "
model {
r0 ~ dbin(p0, n0)
r1 ~ dbin(p1, n1)
r2 ~ dbin(p2, n2)
r3 ~ dbin(p3, n3)
p0 ~ dbeta(1, 1)
p2 ~ dbeta(1, 1)
mu_old ~ dbeta(1, 1)
tau ~ dgamma(0.001, 0.001) # 弱情報事前分布
p1 ~ dbeta(mu_old * tau, (1 - mu_old) * tau)
p3 ~ dbeta(mu_old * tau, (1 - mu_old) * tau)
p2_worse_than_p0 <- step(p2 - p0)
rd_p0_p1 <- p0 - p1
rd_p1_p2 <- p1 - p2
rd_p0_p3 <- p0 - p3
}
"
jags_model <- jags.model(textConnection(model_hier),
data = data_list, n.chains = 2, quiet=TRUE)
update(jags_model, 3000, progress.bar="none")
jags_samples <- coda.samples(jags_model,
c("p0","p1","p2","p3",
"p2_worse_than_p0", "rd_p0_p1","rd_p1_p2", "rd_p0_p3"),
n.iter=10000, progress.bar="none")
gelman.plot(jags_samples)
plot(jags_samples)
js <- as.data.frame(as.matrix(jags_samples))
mean(js$p2_worse_than_p0)
hdi(js$rd_p0_p1) # 旧薬(試験1) vs プラセボ
hdi(js$rd_p1_p2) # 旧薬(試験2) vs 新薬
hdi(js$rd_p0_p3) # 旧薬(試験2) vs プラセボ 仮想
hdi(js$p0-js$p2) # 新薬 vs プラセボ 仮想
source("plotpost.R")
layout(matrix(c(1,2,3,3), 2, 2, byrow=TRUE))
plotpost(js$p2, col='lightcoral',xlab="新薬",cex.lab=1.5,main="")
plotpost(js$p0, col='lightgreen', xlab="プラセボ",cex.lab=1.5,main="")
plotpost(js$p0 - js$p2, compVal = 0, col=c('lightcoral', 'lightgreen'),
xlab="プラセボ - 新薬", cex.main=2,main="二項分布階層モデル",cex.lab=1.5, breaks="scott")
882:１３２人目の素数さん
25/05/17 07:49:04.94 Vpav5/5q.net
library(meta)
library(gemtc)
# データフレームの作成
data <- data.frame(
study = factor(c(1, 1, 2, 2)),
treatment = factor(c("Placebo", "Old", "Old", "New")),
events = c(19, 5, 5, 9),
total = c(202, 201, 204, 203)
)
# 治療効果の比較リスト
comparisons <- c("New - Placebo")
# ネットワークオブジェクトの作成
network <- mtc.network(data = data)
# ランダム効果モデルによるメタアナリシス
model <- mtc.model(network, type = "consistency", likelihood = "binom", link = "logit", linearModel = "random")
# モデルの実行
results <- mtc.run(model)
# 結果の概要
summary(results)
# 新薬 vs プラセボ の効果量（オッズ比）と95%信頼区間
relative.effect(results, "New", "Placebo")
# 新薬がプラセボより劣る確率（P(OR > 1)）を推定
prob.superiority <- 1 - pnorm(0, mean = results$sol[grep("d.New", names(results$sol))], sd = results$se[grep("d.New", names(results$se))])
cat("新薬がプラセボより劣る確率 (間接推定):", prob.superiority, "\n")
# 新薬がプラセボに対して有意に有効かどうかの評価
# オッズ比の95%信頼区間に1が含まれるかどうかで判断
or.new.vs.placebo <- exp(results$sol[grep("d.New", names(results$sol))])
ci.lower <- exp(results$sol[grep("d.New", names(results$sol))] - 1.96 * results$se[grep("d.New", names(results$se))])
ci.upper <- exp(results$sol[grep("d.New", names(results$sol))] + 1.96 * results$se[grep("d.New", names(results$se))])
cat("新薬 vs プラセボ オッズ比 (間接推定):", or.new.vs.placebo, "\n")
cat("95%信頼区間:", ci.lower, "-", ci.upper, "\n")
if (ci.upper < 1) {
cat("新薬はプラセボに対して有意に有効である可能性が高いです。\n")
} else if (ci.lower > 1) {
cat("新薬はプラセボに対して有意に劣る可能性があります。\n")
} else {
cat("新薬とプラセボの間に有意な差は見られない可能性があります。\n")
}
883:１３２人目の素数さん
25/05/20 23:31:13.05 gwaBTE4C.net
library(R2jags)
# データ
data <- list(
nA1 = 100, rA1 = 80, # Study1: 治療A
nB1 = 100, rB1 = 40, # Study1: 治療B
nA2 = 100, rA2 = 10, # Study2: 治療A
nC2 = 100, rC2 = 5 # Study2: 治療C
)
# JAGSモデル（textConnection使用）
model_code <- "
model {
# 尤度関数
rA1 ~ dbin(pA1, nA1)
rB1 ~ dbin(pB1, nB1)
rA2 ~ dbin(pA2, nA2)
rC2 ~ dbin(pC2, nC2)
# 治療Aの階層モデル
mu_A ~ dbeta(1, 1)
tau_A ~ dgamma(0.001, 0.001)
pA1 ~ dbeta(mu_A * tau_A, (1 - mu_A) * tau_A)
pA2 ~ dbeta(mu_A * tau_A, (1 - mu_A) * tau_A)
sigma_A <- 1 / sqrt(tau_A) # SDに変換
# 治療BとCも階層化（平均リスクを別々に推定）
mu_B ~ dbeta(1, 1)
mu_C ~ dbeta(1, 1)
pB1 ~ dbeta(mu_B * 100, (1 - mu_B) * 100) # 高い精度を仮定
pC2 ~ dbeta(mu_C * 100, (1 - mu_C) * 100)
# リスク差
RD_A1_B1 <- pA1 - pB1
RD_A2_C2 <- pA2 - pC2
RD_B1_C2 <- pB1 - pC2 # B vs Cの直接比較
}
"
# JAGS実行
jags_model <-
(textConnection(model_code),
data = data, n.chains = 3, quiet=TRUE)
update(jags_model, 3000) #, progress.bar="none")
jags_samples <- coda.samples(jags_model,
c("mu_A", "sigma_A", "RD_A1_B1", "RD_A2_C2", "RD_B1_C2", "pA1", "pA2", "pB1", "pC2"),
n.iter=10000) # , progress.bar="none")
gelman.plot(jags_samples)
plot(jags_samples)
summary(jags_samples)
jags_samples |> as.matrix() |> as.data.frame() -> js
names(js)
884:１３２人目の素数さん
25/05/23 10:58:19.14 or+7Cxzr.net
#
"
Construct a Monte Carlo study that investigates how the probability of coverage depends on the sample size and true proportion value. In the study, let n be 10, 25, 50, and 100 and let p be .05, .25, and .50. Write an R function that has three inputs, n, p, and the number of Monte Carlo simulations m,and will output the estimate of the exact coverage probability.
Implement your function using each combination of n and p and m = 1000 simulations.
Describe how the actual probability of coverage of the traditional interval depends on the sample size and true proportion value.
"
f = \(n,p,m=1000){
y=rbinom(m,n,p)
phat=y/n
se=sqrt(phat*(1-phat)/n)
lo=phat - qnorm(0.975)*se
up=phat + qnorm(0.975)*se
mean(lo < p & p < up)
}
f=Vectorize(f)
n_values = c(10, 25, 50,100)
p_values = c(0.05, 0.25, 0.5)
set.seed(123)
outer(n_values,p_values,f)
885:１３２人目の素数さん
25/05/24 02:35:14.53 VetM3rz7.net
LearnBayes::beta.selectをoptimを使って算出
beta.optim <- function(x1, p1, x2, p2, verbose = TRUE) {
# -------------------------
# モーメント近似による初期値推定
# -------------------------
mu0 <- (x1 + x2) / 2 # 仮の平均
sigma2 <- ((x2 - x1) / 4)^2 # 仮の分散（中間50%幅から）
v <- mu0 * (1 - mu0) / sigma2 - 1
a0 <- mu0 * v
b0 <- (1 - mu0) * v
start <- c(a0, b0)
# -------------------------
# 最適化対象の誤差関数定義
# -------------------------
objective <- function(params) {
a <- params[1]
b <- params[2]
# pbeta による累積確率との差を2乗誤差で評価
err1 <- pbeta(x1, a, b) - p1
err2 <- pbeta(x2, a, b) - p2
return(err1^2 + err2^2)
}
# -------------------------
# 最適化（境界付き）
# -------------------------
result <- optim(
par = start,
fn = objective,
method = "L-BFGS-B",
lower = c(1e-4, 1e-4) # ベータ分布は a, b > 0
)
# -------------------------
# 結果の取り出し
# -------------------------
a_hat <- result$par[1]
b_hat <- result$par[2]
if (verbose) {
cat("推定されたパラメータ: a =", round(a_hat, 4),
", b =", round(b_hat, 4), "\n")
cat("pbeta(x1) =", round(pbeta(x1, a_hat, b_hat), 4),
"（目標:", p1, "）\n")
cat("pbeta(x2) =", round(pbeta(x2, a_hat, b_hat), 4),
"（目標:", p2, "）\n")
}
# -------------------------
# 結果を返す
# -------------------------
return(list(a = a_hat, b = b_hat, ss_value = result$value))
}
886:１３２人目の素数さん
25/05/24 08:17:52.86 VetM3rz7.net
library(rjags)
# Fit a Bayesian logistic regression model using JAGS and return predictions and posterior summaries
fit_bayesian_logistic_jags <- function(data, formula, newdata,
n.chains = 3, n.iter = 5000, n.burnin = 1000) {
# Extract response variable name from the formula
response_var <- all.vars(formula)[1]
y <- data[[response_var]]
# Convert factor response to binary numeric (0/1)
if (is.factor(y)) y <- as.numeric(y) - 1
y <- as.numeric(y)
# Construct design matrices for training and new data
X <- model.matrix(formula, data)
new_X <- model.matrix(delete.response(terms(formula)), newdata)
# Prepare data list for JAGS
jags_data <- list(
y = y,
X = X,
n = nrow(X),
p = ncol(X),
new_X = new_X,
scale_beta = rep(2.5, ncol(X)) # Prior scale for each coefficient
)
# Define the JAGS model
model_string <- "
model {
for (j in 1:p) {
beta[j] ~ dt(0, 1 / pow(scale_beta[j], 2), 1)
}
for (i in 1:n) {
logit_p[i] <- inprod(X[i,], beta[])
y[i] ~ dbern(1 / (1 + exp(-logit_p[i])))
}
new_logit <- inprod(new_X[1,], beta[])
new_p <- 1 / (1 + exp(-new_logit))
}
"
# Initialize and run the JAGS model
model <- jags.model(textConnection(model_string), data = jags_data,
n.chains = n.chains, quiet = TRUE)
update(model, n.burnin)
# Draw posterior samples
samples <- coda.samples(model, c("beta", "new_p"), n.iter - n.burnin)
mat <- as.matrix(samples)
# Return results
list(
model = samples,
predicted_prob = mean(mat[, "new_p"]),
summary = summary(samples)
)
}
887:１３２人目の素数さん
25/05/24 08:18:19.92 VetM3rz7.net
# Example data
data <- data.frame(
donation = c(0, 1000, 2000, 0, 3000, 0, 4000, 0, 5000, 0),
score = c(90, 40, 35, 88, 30, 85, 25, 92, 20, 89),
parent = c(0, 1, 1, 0, 1, 0, 1, 0, 1, 0),
admission = as.factor(c(0, 1, 1, 0, 1, 0, 1, 0, 1, 0))
)
# New observation to predict
newdata <- data.frame(
donation = 2500,
score = 40,
parent = 1
)
# Fit model and obtain results
set.seed(123)
result <- fit_bayesian_logistic_jags(
data = data,
formula = admission ~ donation + score + parent,
newdata = newdata
)
# Extract variable names including intercept
var_names <- colnames(model.matrix(admission ~ donation + score + parent, data))
# Extract beta coefficient summaries
beta_stats <- result$summary$statistics[grep("^beta\\[", rownames(result$summary$statistics)), c("Mean", "SD")]
beta_quants <- result$summary$quantiles[grep("^beta\\[", rownames(result$summary$quantiles)), c("2.5%", "97.5%")]
# Rename row names using variable names
rownames(beta_stats) <- var_names
rownames(beta_quants) <- var_names
# Display results
print(beta_stats)
print(beta_quants)
cat("Predicted probability:", round(result$predicted_prob, 3), "\n")
888:１３２人目の素数さん
25/05/24 08:37:05.75 VetM3rz7.net
library(rjags)
# Fit a Bayesian logistic regression model using JAGS and return predictions and posterior summaries
fit_bayesian_logistic_jags <- function(data, formula, newdata,
n.chains = 3, n.iter = 5000, n.burnin = 1000) {
# Extract response variable name from the formula
response_var <- all.vars(formula)[1]
y <- data[[response_var]]
# Convert factor response to binary numeric (0/1)
if (is.factor(y)) y <- as.numeric(y) - 1
y <- as.numeric(y)
# Construct design matrices for training and new data
X <- model.matrix(formula, data)
new_X <- model.matrix(delete.response(terms(formula)), newdata)
# Prepare data list for JAGS
jags_data <- list(
y = y,
X = X,
n = nrow(X),
p = ncol(X),
new_X = new_X,
scale_beta = rep(2.5, ncol(X)) # Prior scale for each coefficient
)
# Define the JAGS model
model_string <- "
model {
for (j in 1:p) {
beta[j] ~ dt(0, 1 / pow(scale_beta[j], 2), 1)
}
for (i in 1:n) {
logit_p[i] <- inprod(X[i,], beta[])
y[i] ~ dbern(1 / (1 + exp(-logit_p[i])))
}
new_logit <- inprod(new_X[1,], beta[])
new_p <- 1 / (1 + exp(-new_logit))
}
"
# Initialize and run the JAGS model
model <- jags.model(textConnection(model_string), data = jags_data,
n.chains = n.chains, quiet = TRUE)
update(model, n.burnin)
# Draw posterior samples
samples <- coda.samples(model, c("beta", "new_p"), n.iter - n.burnin)
mat <- as.matrix(samples)
# Return results
list(
model = samples,
predicted_prob = mean(mat[, "new_p"]),
summary = summary(samples)
)
}
889:１３２人目の素数さん
25/05/24 21:16:24.84 VetM3rz7.net
# dbeta(L,a,b) == dbbeta(U,a,b)
# Solve[L^(a-1)(1-L)^(b-1)==U^(a-1)(1-U)^(b-1), b]
L=1/7
U=1/5
credMass = 0.95
f = function(a) 1 + ((a - 1) * log(U / L)) / log((1 - L) / (1 - U))
g = function(a) pbeta(U,a,f(a)) - pbeta(L,a,f(a)) - credMass
(re=uniroot(g,c(1,1e5)))
curve(g(x),1,150,bty="l") ; abline(h=0,lty=3)
c(re$root,f(re$root))
890:１３２人目の素数さん
25/05/25 04:22:37.55 P4nhnL8B.net
# dbeta(L,a,b) == dbbeta(U,a,b)
# Solve[L^(a-1)(1-L)^(b-1)==U^(a-1)(1-U)^(b-1), b]
L=1/7
U=1/5
credMass = 0.95
f = function(a) 1 + ((a - 1) * log(U / L)) / log((1 - L) / (1 - U))
g = function(a) pbeta(U,a,f(a)) - pbeta(L,a,f(a)) - credMass
(re=uniroot(g,c(1,1e5)))
a=re$root
b=f(a)
c(a,b)
curve(g(x),1,1.5*a,bty="l") ; abline(h=0,lty=3)
a/(a+b) # mean
(a-1)/(a-1+b-1) # mode
library(LearnBayes)
beta.select(list(x=1/7,p=0.025),list(x=1/5,p=0.975))
891:１３２人目の素数さん
25/05/25 05:57:52.88 P4nhnL8B.net
＞847のRのコードをChatGPTで
Mathematicaにコメント付きで移植
(*
betaParameter 関数：
指定された信頼区間 [L, U] に、指定された信頼度 credMass（例: 95%）の確率質量を持つ
ベータ分布のパラメータ α, β を算出する。
*)
betaParameter[L_: 1/7, U_: 1/5, credMass_: 0.95] := Module[
{α, β},
(*
f[α] は、PDF[BetaDistribution[α, β], L] == PDF[BetaDistribution[α, β], U]
を満たすように β を α に基づいて算出する関数。
*)
f[α_] := 1 + ((α - 1) * Log[U / L]) / Log[(1 - L) / (1 - U)];
(*
g[α] は、ベータ分布 Beta[α, f[α]] の区間 [L, U] に
含まれる確率（CDFの差）を返す関数。
*)
g[α_] := CDF[BetaDistribution[α, f[α]], U] - CDF[BetaDistribution[α, f[α]], L];
(* g[α] = credMass を満たす α を数値的に求める *)
α = α /. FindRoot[g[α] == credMass, {α, 1, 1*^5}];
(* 対応する β を算出 *)
β = f[α];
(* 結果を返す *)
{α, β}
]
(* 関数を実行して α, β を取得 *)
{α, β} = betaParameter[]
(* g[α] を評価して、[L, U] に credMass の質量があることを確認 *)
g[α]
892:１３２人目の素数さん
25/05/25 06:42:27.34 P4nhnL8B.net
>>849
このプロトタイプをAIに与えて描画機能やコメントをつけてもらった。
beta.parameter <- function(lower, upper, credMass = 0.95, verbose = FALSE) {
# Helper function to convert decimal numbers to fraction strings using MASS::fractions
fractionStr <- function(x) {
as.character(MASS::fractions(x))
}
# Function to compute beta parameter (beta) based on alpha,
# derived from the condition on the shape of the distribution between lower and upper
f <- function(alpha) {
1 + ((alpha - 1) * log(upper / lower)) / log((1 - lower) / (1 - upper))
}
# Root-finding function: difference between desired credible mass
# and the Beta CDF probability between lower and upper with parameters (alpha, f(alpha))
g <- function(alpha) {
pbeta(upper, alpha, f(alpha)) - pbeta(lower, alpha, f(alpha)) - credMass
}
# Find the root of g(alpha) = 0 over the interval [1, 1e5]
# to find the alpha value that satisfies the credible mass condition
re <- uniroot(g, c(1, 1e5))
alpha <- re$root
beta <- f(alpha)
# Calculate the mean of the Beta distribution
mean <- alpha / (alpha + beta)
# Calculate the mode if defined (alpha > 1 and beta > 1),
# otherwise set mode to NA as it is undefined
mode <- if (alpha > 1 && beta > 1) {
(alpha - 1) / (alpha + beta - 2)
} else {
NA
}
893:１３２人目の素数さん
25/05/25 06:42:37.76 P4nhnL8B.net
# If verbose flag is TRUE, plot the Beta distribution and annotate results
if (verbose) {
# Generate x values from 0 to 1 for plotting the density
x <- seq(0, 1, length.out = 1000)
# Compute Beta density values at x
y <- dbeta(x, alpha, beta)
# Color bars within the credible interval [lower, upper] as "lightcoral",
# others as light gray ("gray70")
col <- ifelse(x >= lower & x <= upper, "lightcoral", "gray70")
# Plot histogram-like vertical lines representing the Beta density
plot(x, y, type = "h", col = col, lwd = 2,
main = sprintf("Beta(%.2f, %.2f) Distribution\n[%s, %s] with %.0f%% Probability Mass",
alpha, beta, fractionStr(lower), fractionStr(upper), credMass * 100),
xlab = "x", ylab = "Density", bty = "n")
# Add vertical dashed line for the mean, colored skyblue
abline(v = mean, col = "skyblue", lwd = 1, lty = 2)
# Add vertical dashed line for the mode if defined, colored dark green
if (!is.na(mode)) {
abline(v = mode, col = "darkgreen", lwd = 1, lty = 2)
}
# Prepare legend labels for mean, mode (if exists), and credible interval
labels <- c(
paste0("Mean = ", round(mean,
894:3)), if (!is.na(mode)) paste0("Mode = ", round(mode, 3)) else NULL, paste0("95% Credible Interval [", fractionStr(lower), ", ", fractionStr(upper), "]") ) # Corresponding colors for legend items colors <- c( "skyblue", if (!is.na(mode)) "darkgreen" else NULL, "lightcoral" ) # Line types for legend items (dashed lines for mean and mode, none for credible interval) ltys <- c(2, if (!is.na(mode)) 2 else NULL, NA) # Plot characters for legend (none for lines, solid square for interval) pchs <- c(NA, if (!is.na(mode)) NA else NULL, 15) # Add legend at the top of the plot with no box, scaled text size legend("top", legend = labels, col = colors, bty = "n", cex = 0.9, lty = ltys, pch = pchs) } # Return a named vector of calculated parameters and statistics c(alpha = alpha, beta = beta, mean = mean, mode = mode) }
895:１３２人目の素数さん
25/05/25 06:51:16.85 P4nhnL8B.net
今回スムーズに機能拡張できた理由は、以下のようにプロトタイプが非常に明快かつ健全だったことが大きな要因です。
✅ プロトタイプの良さが拡張性を支えた理由
1. 構造がシンプル
中心となる数式（pbeta(U, a, b) - pbeta(L, a, b) = credMass）が明確で、ロジックが一貫していました。
f(a) で b を a の関数として定義しており、探索空間を1次元に抑えていた点も効率的。
2. 関数分離と再利用が可能
f(a) や g(a) が関数として定義されていたので、視覚化やバリエーションの追加が簡単でした。
3. 出力が明確
c(a, b) と返す構造が明瞭で、追加情報（期待値・最頻値など）も素直に足せました。
4. 数値的安定性が良好
uniroot() による根の探索は数値計算としても信頼性が高く、実用的。
896:１３２人目の素数さん
25/05/25 10:38:10.59 P4nhnL8B.net
HDI_discrete <- function(prob_data, credMass) {
x = prob_data[, 1]
p = prob_data[, 2]
n = length(x)
sp = sort(p, index.return = TRUE)
i = sp$ix[seq(n, 1, -1)]
ps = p[i]
xs = x[i]
cp = cumsum(ps)
ii = 1:n
j = ii[cp >= credMass]
j = j[1]
achieved_credMass = cp[j]
hdi_set = sort(xs[1:j])
v = list(credMass = achieved_credMass, set = hdi_set)
return(v)
}
897:１３２人目の素数さん
25/05/29 17:36:18.23 WPcwJ6cn.net
"
サイコロを50回なげて4回１の目がでた。
１の目のでる確率は1/6である仮説が正しい確率を求めよ。
計算に必要なモデルは適宜設定してよい。
例：サイコロを投げる前のこの仮説が正しい確率は一様分布に従う。
a/(a+b)=p
a=p(a+b)
(1-p)a=pb
b=a*(1-p)/p
a=b*p/(1-p)
a/b=p/(1-p)
"
rm(list=ls())
p=1/6
n=50
y=4
pbinom(y,n,p)
dbinom(y,n,p)
fn <- function(prob){
sub <-function(alpha) pbetat(p,prob,c(1,(1-p)/p)*alpha,c(y,n-y))$post
optimize(sub,c(1,100))$objective
}
fn = Vectorize(fn)
fn(0.5)
prior.probs=runif(1e6)
post.probs=fn(prior.probs)
summary(post.probs)
HDInterval::hdi(post.probs)
source("plotpost.R")
plotpost(post.probs,col="lightcoral")
lines(density(post.probs))
898:１３２人目の素数さん
25/05/30 06:24:20.07 zoAuXcvc.net
par(bty="l")
y = c(43, 24, 100, 35, 85)
yn = max(y)
n = length(y)
B = 200
like = numeric(B)
for(i in yn:B) { like[i] = 1 / (i^n) }
pmf = like / sum(like)
mean = sum((1:B) * pmf)
plot(pmf, main="Posterior PMF of N", xlab="N", ylab="Probability", type="h", col="blue")
plot(cumsum(pmf), main="Posterior CDF of N", xlab="N", ylab="Cumulative Probability", type="s", col="blue")
abline(h=0.95, lty=3)
c(lower=yn, mean=mean, upper=which(cumsum(pmf) > 0.95)[1])
sd = sqrt(sum(((1:B) - mean)^2 * pmf))
prob_N_gt_150 = sum(pmf[151:B])
cat("Posterior Mean:", mean, "\n")
cat("Posterior Standard Deviation:", sd, "\n")
cat("P(N > 150):", prob_N_gt_150, "\n")
899:１３２人目の素数さん
25/05/30 19:44:31.38 zoAuXcvc.net
(* pbetat関数の定義 *)
pbetat[p0_, prob_, ab_, data_] := Module[{a, b, s, f, lbf, bf, post},
a = ab[[1]];
b = ab[[2]];
s = data[[1]];
f = data[[2]];
lbf = s * Log[p0] + f * Log[1 - p0] + Log@Beta[a, b] - Log@Beta[a + s, b + f];
bf = Exp[lbf];
post = prob * bf / (prob * bf + 1 - prob);
<|"bf" -> bf, "post" -> post|>
]
(* 関数fの定義 *)
f[alpha_] := pbetat[1/6, 0.5, {alpha, 5*alpha - 4}, {4, 50 - 4}]["post"]
(* 最小化 *)
result = NMinimize[{f[alpha], 0 <= alpha <= 20}, alpha]
900:１３２人目の素数さん
25/05/30 20:13:47.71 zoAuXcvc.net
p_post_null <- function(p0, prior, alpha, beta, success, failure){
# Calculate the total number of trials from successes and failures.
total = success + failure
# Calculate the likelihood of the data under the null hypothesis (H0).
# This assumes a binomial distribution where the success probability is p0.
m0 = dbinom(success, total, p0)
# Calculate the marginal likelihood of the data under the alternative hypothesis (H1).
# Under H1, the success probability is assumed to follow a Beta distribution
# with parameters alpha and beta. This function (from the 'extraDistr' package)
# computes the marginal likelihood by integrating over all possible success probabilities.
m1 = extraDistr::dbbinom(success, total, alpha, beta)
# Calculate the Bayes Factor (BF01).
# This is the ratio of the likelihood under the null hypothesis (m0)
# to the marginal likelihood under the alternative hypothesis (m1).
BF01 = m0 / m1
# Calculate the posterior probability of the null hypothesis.
# This updates the prior belief (prior) based on the evidence from the data (BF01).
p_post = prior * BF01 / (prior * BF01 + 1 - prior)
# Return both the Bayes Factor and the posterior probability as a named vector.
c(BF01 = BF01, p_post = p_post)
}
# Optimize the 'alpha' parameter to maximize the posterior probability of the null hypothesis.
# We're trying to find the 'alpha' value (within the range 0 to 1e6) that makes the
# null hypothesis most plausible, given the data and the relationship beta = 5*alpha - 4.
# p_post_null(...)[2] specifically extracts the 'p_post' value from the function's output.
optimize(function(alpha) p_post_null(p0 = 1/6,
prior = 1/2,
alpha,
5 * alpha - 4, # Beta parameter is a function of alpha
success = 4,
failure = 50 - 4)[2],
c(0, 1e6)) # Search range for alpha
# Calculate the Bayes Factor and posterior probability using specific alpha and beta values.
# These specific values (alpha = 50/9, beta = 5*50/9 - 4) are likely the result of the
# optimization step above, or pre-determined values that are of interest.
p_post_null(1/6, 1/2, 50/9, 5 * 50/9 - 4, 4, 50 - 4)
901:１３２人目の素数さん
25/05/31 05:25:02.62 jzcOJBMt.net
#' @title ベイズ事後確率計算関数
#' @description 帰無仮説と対立仮説の事後確率を計算
#' @param s 観測成功数（1の目が出た回数）
#' @param n 総試行回数
#' @param p0 帰無仮説の確率（例: 1/6）
#' @param prior 帰無仮説の事前確率（0～1）
#' @param alpha 対立仮説のベータ分布αパラメータ
#' @param beta 対立仮説のベータ分布βパラメータ
#' @return list(bf01=ベイズフ�
902:@クター, post=事後確率, method=使用手法) calculate_posterior <- function(s, n, p0, prior, alpha, beta) { # 入力検証 stopifnot( s >= 0, n > 0, p0 > 0 && p0 < 1, prior >= 0 && prior <= 1, alpha > 0, beta > 0 ) # 帰無仮説の尤度計算 m0 <- dbinom(s, n, p0) # 対立仮説の周辺尤度計算（extraDistr有無で自動切替） if (requireNamespace("extraDistr", quietly = TRUE)) { m1 <- extraDistr::dbbinom(s, n, alpha, beta) method <- "extraDistr::dbbinom()" } else { integrand <- function(p) dbinom(s, n, p) * dbeta(p, alpha, beta) m1 <- integrate(integrand, 0, 1)$value method <- "数値積分" } # ベイズファクターと事後確率計算（指定された式を使用） bf01 <- m0 / m1 post <- m0 * prior / (m0 * prior + (1 - prior) * m1) # 結果をリストで返す list( bf01 = bf01, post = post, method = method, inputs = list(s = s, n = n, p0 = p0, prior = prior, alpha = alpha, beta = beta), likelihoods = list(m0 = m0, m1 = m1) ) }
903:１３２人目の素数さん
25/06/01 07:35:56.27 /PZFDI/g.net
auc = integrate(unnorm_posterior,0,Inf)$value
integrate(\(x) x*unnorm_posterior(x)/auc, 0,Inf)
log_auc <- log(integrate(\(x) exp(log(unnorm_posterior(x))), 0, Inf)$value)
integrate(\(x) x * exp(log(unnorm_posterior(x)) - log_auc), 0, Inf)$value
904:１３２人目の素数さん
25/06/01 09:23:27.85 9o1m2vAK.net
Calculate the marginal likelihood of the data under the alternative hypothesis (H1).
wwwwwwwwwwwwwwwwwwwwwwwwwwwwww
あほ～～
wwwwwwwwwwwwwwwwwwwwwwwwwwwwww
905:１３２人目の素数さん
25/06/01 10:41:31.84 /PZFDI/g.net
はい、Gelmanらの推奨は確かに進化しており、近年ではハーフt分布（half-t）がより一般的に推奨されています。この変化の背景と具体的な推奨内容を、理論的根拠と実践的なアドバイスに分けて解説します。
1. Gelmanの推奨の変遷
(1) 初期（2006年頃）: ハーフコーシー（自由度ν=1）の推奨
推奨理由:
分散パラメータの弱情報事前分布として適切
裾が重く、極端な値への過剰なペナルティを回避
問題点:
自由度ν=1ではスケールの選択に敏感
小規模データで不安定になる可能性
(2) 近年（2013年以降）: 自由度ν>1のハーフt分布へ移行
推奨理由:
自由度ν=3～7でより安定した推定が可能
スケールパラメータの影響が緩和
代表的な論文:
Gelman et al. (2013), "The Prior Can Often Only Be Understood in the Context of the Likelihood"
906:１３２人目の素数さん
25/06/02 11:14:31.22 GMuHFUYr.net
x = c(-0.86, -0.3, -0.05, 0.73)
n = c(5, 5, 5, 5)
y = c(0, 1, 3, 5)
(data = cbind(x, n, y))
(response = cbind(y, n - y) )
results = glm(response ~ x, family = binomial)
#summary(results)
-results$coef[1]/results$coef[2]
library(MASS) # mvrnorm を使うため
# 推定された係数と共分散行列
beta_hat = coef(results)
(vcov_matrix = vcov(results))
# 多変量正規乱数を生成（β0, β1）
set.seed(123) # 再現性のため
samples = mvrnorm(n = 10000, mu = beta_hat, Sigma = vcov_matrix)
# 各サンプルから LD50 を計算
LD50_samples = -samples[,1] / samples[,2]
# 信頼区間（95%）
CI = quantile(LD50_samples, probs = c(0.025, 0.975))
# 結果表示
cat("シミュレーションによるLD50の95%信頼区間:\n")
print(CI)
907:１３２人目の素数さん
25/06/02 12:04:32.64 GMuHFUYr.net
# データ
x <- c(-0.86, -0.3, -0.05, 0.73)
n <- c(5, 5, 5, 5)
y <- c(0, 1, 3, 5)
# JAGSモデル
model_string <- "
model {
for (i in 1:N) {
y[i] ~ dbin(p[i], n[i])
logit(p[i]) <- beta0 + beta1 * x[i]
}
# 事前分布（非情報的）
beta0 ~ dnorm(0.0, 0.001)
beta1 ~ dnorm(0.0, 0.001)
# LD50の定義
LD50 <- -beta0 / beta1
}
"
# JAGSに渡すデータ
data_jags <- list(
x = x,
n = n,
y = y,
N = length(y)
)
# 初期値
inits <- function() {
list(beta0 = rnorm(1, 0, 1), beta1 = rnorm(1, 0, 1))
}
# モデル作成と実行
model <- jags.model(textConnection(model_string), data = data_jags, inits = inits, n.chains = 3)
update(model, 1000) # バーンイン
# サンプリング
samples <- coda.samples(model, variable.names = c("beta0", "beta1", "LD50"), n.iter = 10000)
# 結果表示（LD50の95%信用区間）
summary(samples)
LD50_samples <- as.matrix(samples)[, "LD50"]
quantile(LD50_samples, probs = c(0.025, 0.975))
plot(samples)
908:１３２人目の素数さん
25/06/03 00:31:29.12 CfA5PBxZ.net
x = c(-0.86, -0.3, -0.05, 0.73)
n = c(5, 5, 5, 5)
y = c(0, 1, 3, 5)
(data = cbind(x, n, y))
(response = cbind(y, n - y) )
results = glm(response ~ x, family = binomial(link="logit") )
summary(results)
b=MASS::mvrnorm(1e5,results$coef,S=vcov(results))
# log(p/(1-p)) = b1+b2*x
LD = function(b1,b2,p=0.5) (log(p/(1-p)) - b1)/b2
LD50=mapply(LD,b[,1],b[,2])
hist(LD50)
quantile(LD50,c(0.025,0.5,0.975))
HDInterval::hdi(LD50)
909:１３２人目の素数さん
25/06/03 23:40:25.34 CfA5PBxZ.net
k=10
m=400
Nmax=1000
sim = \(){
N=sample(m:Nmax,1)
if(max(sample(1:N,k))==m) return(N)
}
N=NULL
while(length(N)<1000) N=c(N,sim())
summary(N)
quantile(N,c(0.5,0.95))
910:１３２人目の素数さん
25/06/04 07:49:17.80 n75lIIio.net
set.seed(123)
solve = function(x,k=1e5){
f = function(x) runif(1,x-0.5,x+0.5)
y=replicate(k,mean(sapply(x,f)))
quantile(y,p=c(0.025,0.975))
}
solve(c(9,10,11,11,12))
set.seed(123) # 再現性のため
solve2 <- function(x, k = 1e5) {
# 各x_iに対して一様乱数を生成し、平均を計算（ブートストラップ）
bootstrap_means <- replicate(k, {
x_true <- runif(length(x), x - 0.5, x + 0.5)
mean(x_true)
})
# 95%信頼区間を計算
quantile(bootstrap_means, probs = c(0.025, 0.975))
}
# 実行例
x_rounded <- c(9, 10, 11, 11, 12)
solve2(x_rounded)
911:１３２人目の素数さん
25/06/05 13:25:27.68 tGlaBVfa.net
> stancode(fit)
// generated with brms 2.22.0
functions {
/* compute monotonic effects
* Args:
* scale: a simplex parameter
* i: index to sum over the simplex
* Returns:
* a scalar between 0 and rows(scale)
*/
real mo(vector scale, int i) {
if (i == 0) {
return 0;
} else {
return rows(scale) * sum(scale[1:i]);
}
}
}
data {
int<lower=1> N; // total number of observations
array[N] int Y; // response variable
int<lower=1> K; // number of population-level effects
matrix[N, K] X; // population-level design matrix
int<lower=1> Kc; // number of population-level effects after centering
int<lower=1> Ksp; // number of special effects terms
int<lower=1> Imo; // number of monotonic variables
array[Imo] int<lower=1> Jmo; // length of simplexes
array[N] int Xmo_1; // monotonic variable
vector[Jmo[1]] con_simo_1; // prior concentration of monotonic simplex
int prior_only; // should the likelihood be ignored?
}
transformed data {
matrix[N, Kc] Xc; // centered version of X without an intercept
vector[Kc] means_X; // column means of X before centering
for (i in 2:K) {
means_X[i - 1] = mean(X[, i]);
Xc[, i - 1] = X[, i] - means_X[i - 1];
}
}
parameters {
vector[Kc] b; // regression coefficients
real Intercept; // temporary intercept for centered predictors
simplex[Jmo[1]] simo_1; // monotonic simplex
vector[Ksp] bsp; // special effects coefficients
}
transformed parameters {
real lprior = 0; // prior contributions to the log posterior
lprior += normal_lpdf(b[1] | 0.15, 0.3);
lprior += normal_lpdf(b[2] | 0.08, 0.3);
lprior += normal_lpdf(b[3] | 0.8, 0.3);
lprior += normal_lpdf(b[4] | 0.5, 0.3);
lprior += normal_lpdf(Intercept | -4, 2);
lprior += dirichlet_lpdf(simo_1 | con_simo_1);
lprior += normal_lpdf(bsp[1] | -0.5, 0.3);
}
model {
// likelihood including constants
if (!prior_only) {
// initialize linear predictor term
vector[N] mu = rep_vector(0.0, N);
mu += Intercept;
for (n in 1:N) {
// add more terms to the linear predictor
mu[n] += (bsp[1]) * mo(simo_1, Xmo_1[n]);
}
target += bernoulli_logit_glm_lpmf(Y | Xc, mu, b);
}
// priors including constants
target += lprior;
}
generated quantities {
// actual population-level intercept
real b_Intercept = Intercept - dot_product(means_X, b);
}
912:１３２人目の素数さん
25/06/06 04:41:04.79 fR053ZqC.net
# ロジスティック回帰モデル
ACT = c(16,18,20,22,24,26,28)
n = c(2,7,14,26,13,14,3)
y = c(0,0,6,12,7,9,3)
fit = glm(cbind(y, n - y) ~ ACT, family = binomial())
#predict(fit, newdata = data.frame(ACT = 20)) |> plogis()
predict(fit, newdata = data.frame(ACT = 20)
,type="response")
cat("\n\n===== se.fit=TRUE =====\n\n")
pred1=predict(fit, newdata = data.frame(ACT = 20)
,type="response",se.fit=TRUE)
# 信頼区間（response))結果表示
ci=c(pred1$fit - 1.96*pred1$se.fit,pred1$fit + 1.96*pred1$se.fit)
cat("95% 信頼区間: [", ci[1], ",", ci[2], "]\n")
# 予測（log-odds とその標準誤差）
pred = predict(fit, newdata = data.frame(ACT = 20), se.fit = TRUE)
# 信頼区間（log-odds）
log_odds = pred$fit
se = pred$se.fit
lower_log_odds = log_odds - 1.96 * se
upper_log_odds = log_odds + 1.96 * se
# 確率（ロジスティック関数で変換）
prob = plogis(log_odds)
lower_prob = plogis(lower_log_odds)
upper_prob = plogis(upper_log_odds)
# 結果表示
cat("95% 信頼区間: [", lower_prob, ",", upper_prob, "]\n")
913:１３２人目の素数さん
25/06/06 04:43:11.66 fR053ZqC.net
確率は0～1の範囲に制限されるため、直接計算は境界（0や1）に近い場合に不適切（例: 負の値や1超えの可能性）。また、ロジスティック回帰の標準誤差はログオッズスケールで計算されるため、確率スケールでの線形近似は精度が落ちる。
914:１３２人目の素数さん
25/06/06 06:49:45.63 rCqJxG6F.net
お前には永遠に確率論なんて無理だよ。
数学Bの統計すらわからないのに。
自分が理解できていないことすら理解できないゴミ
915:１３２人目の素数さん
25/06/06 08:42:32.31 icvPdYuT.net
公式当てはめてるだけだからな
じゃあその公式をどうやって証明するかまでは考えが及ばない
やってることは公文式で大学生の演習解いてる中学生と一緒
916:１３２人目の素数さん
25/06/12 09:46:29.84 z7P0Lqdi.net
Bayesian Computation with RでRのコードが理解できなかった。バグだとおもったのだが、
URLﾘﾝｸ(bayesball.github.io)
のerrataにも掲載がないのでAIに聞いてみた。
>>
対数ヤコビアン項が間違っていると思う。
# theta=c(log(eta/(1-eta)),log(K))
> LearnBayes::betabinexch
function (theta, data)
{
eta = exp(theta[1])/(1 + exp(theta[1]))
K = exp(theta[2])
y = data[, 1]
n = data[, 2]
N = length(y)
logf = function(y, n, K, eta) lbeta(K * eta + y, K * (1 -
eta) + n - y) - lbeta(K * eta, K * (1 - eta))
val = sum(logf(y, n, K, eta))
val = val + theta[2] - 2 * log(1 + exp(theta[2]))
return(val)
}
<bytecode: 0x000001a5a980e758>
917:<environment: namespace:LearnBayes> これが正しいのでは？ betabinexch <- function (theta, data) { eta = exp(theta[1])/(1 + exp(theta[1])) K = exp(theta[2]) y = data[, 1] n = data[, 2] N = length(y) logf = function(y, n, K, eta) lbeta(K * eta + y, K * (1 - eta) + n - y) - lbeta(K * eta, K * (1 - eta)) val = sum(logf(y, n, K, eta)) val = val + theta[1] + theta[2] - 2 * log(1 + exp(theta[1])) # log Jacobian term return(val) } << いずれのAIも >あなたの指摘は正しいです。対数ヤコビアン項に問題があります。 という趣旨の返事が返ってきた。
918:１３２人目の素数さん
25/06/12 18:10:24.36 CDb/RdAY.net
>>873
脳内医者完全にバレたのにまだ頑張ってるんだ
哀れだね
919:１３２人目の素数さん
25/06/12 18:20:13.54 QiRqli9X.net
>>873
バグだと思ったのにIssueもあげないの？
スレの私的利用といい、マジで他人の成果やタイトルに乗っかるだけの寄生虫じゃん
税金も年金もコイツに使うだけ無駄だよ
920:１３２人目の素数さん
25/06/12 18:27:36.57 CDb/RdAY.net
>>873に質問！
当然入試でも満点が取れる解答以外認めません
①円周率が3.05より大きいことを証明せよ。
ただし円周率は(円周)/(円の直径)と定義され、円周率が3.14より大きい事は判明していないものとする。
②√2+√3が無理数であることを証明せよ。
921:１３２人目の素数さん
25/06/13 07:38:09.90 XjvE6Ide.net
>>876
証明問題解けないんだから、人のした証明が正しいかの判断できないだろ
922:１３２人目の素数さん
25/06/14 05:53:33.29 nWbGzc8A.net
（1）nを正整数とする。
n^3+4n^2+3nを6で割った余りを求めよ。
（2）nを正整数とする。
n^3+7n^2+5nを6で割った余りを求めよ。
923:１３２人目の素数さん
25/06/14 10:23:41.50 c0/MskJB.net
>>878
（2）が傑作でございます
924:１３２人目の素数さん
25/06/15 01:22:01.50 bEUsomGs.net
>>878
n^3+7n^2+5n
=n(n^2+7n+5)
=n{(n+1)(n+2)+3(n+1)+n}
・n(n+1)(n+2)は3連続の正整数の積なので6の倍数
・n(n+1)は偶数なので3n(n+1)は6の倍数
したがってn^3+7n^2+5nを6で割った余りはn^2を6で割った余りに等しい。
n=6kのとき、求める余りは0
n=6k+1のとき、求める余りは1
n=6k+2のとき、求める余りは4
n=6k+3のとき、求める余りは3
n=6k+4のとき、求める余りは4
n=6k+5のとき、求める余りは1
925:１３２人目の素数さん
25/06/15 08:32:56.90 MIIBNstg.net
pdf2hdi <- function(pdf,
xMIN=0,
xMAX=1,
cred=0.95,
Print=TRUE,
nxx=1001){
xx=seq(xMIN,xMAX,length=nxx)
xx=xx[-nxx]
xx=xx[-1]
xmin=xx[1]
xmax=xx[nxx-2]
AUC=integrate(pdf,xmin,xmax)$value
PDF=function(x)pdf(x)/AUC
cdf <- function(x) integrate(PDF,xmin,x)$value
ICDF <- function(x) uniroot(function(y) cdf(y)-x,c(xmin,xmax))$root
ICDF=Vectorize(ICDF)
hdi=HDInterval::hdi(ICDF,credMass=cred)
print(c(hdi[1],hdi[2]),digits=5)
if(Print){
par(mfrow=c(3,1))
plot(xx,sapply(xx,PDF),main='pdf',type='h',xlab='x',ylab='Density',col='lightgreen',bty='l')
legend('top',bty='n',legend=paste('HDI:',round(hdi,3)))
plot(xx,sapply(xx,cdf),main='cdf',type='h',xlab='x',ylab='Probability',col='lightblue',bty='l')
pp=seq(0,1,length=nxx)
pp=pp[-nxx]
pp=pp[-1]
plot(pp,sapply(pp,ICDF),type='l',xlab='p',ylab='x',main='ICDF',bty='l')
par(mfrow=c(1,1))
}
invisible(ICDF)
}
ICDF=pdf2hdi(function(x) dbeta(x,2,5))
hist(ICDF(seq(1e-12,1-1e-12,le=1000)))
AIの評価
まとめ
この pdf2hdi 関数は、数値積分と数値最適化 (uniroot) を巧みに組み合わせることで、任意のPDFからICDFを頑健に導出し、さらに統計的な要約であるHDIを計算する、非常に実用的かつ教育的なコードです。両端での数値計算の回避や正規化といった細部への配慮も素晴らしいです。
これにより、複雑な確率分布でも、そこからサンプリングしたり、HDIを求めたりといった解析が可能になります。
926:１３２人目の素数さん
25/06/15 18:28:56.06 /Vl5yuRp.net
>>873
あれ？息しなくなったの？
927:１３２人目の素数さん
25/06/15 21:18:52.53 iKpVgdzy.net
こんな糞スレさっさと埋めちまおう
なんだよ医者専用って
医者が数学板わざわざ来ねぇだろw
928:１３２人目の素数さん
25/06/15 21:44:35.19 THc6UTle.net
スレ立てたのは自分じゃないが恐らく尿瓶ジジイが自称医者だからゴキブリホイホイしてるだけ
それももう誰の目からも医者じゃないことが丸わかりになってこれ以上数学板でも医者のフリができなくなったから息ができなくなっただけ
929:１３２人目の素数さん
25/06/16 14:42:50.11 C9BO4dk2.net
（1）nを正整数とする。
n^3+4n^2+3nを6で割った余りを求めよ。
（2）nを正整数とする。
n^3+7n^2+5nを6で割った余りを求めよ。
これの解答はまだですか？
930:１３２人目の素数さん
25/06/17 14:25:14.36 0Sosw64R.net
（1）nを正整数とする。
n^3+4n^2+3nを6で割った余りを求めよ。
（2）nを正整数とする。
n^3+7n^2+5nを6で割った余りを求めよ。
この傑作に解答しなさい。
余りの処理を簡潔に行う方法は何か？
931:１３２人目の素数さん
25/06/19 09:36:40.21 Kb+ol8z3.net
プログラムが弄れる医者や東大卒なら自力で算出できる問題。
Fランや裏口シリツ医には無理。
直線上にならんだ池が６個ある。１～６と命名する。
池にはカエルがいる。
観察の結果、カエルは翌日には５０％の確率で隣の池に移る。
隣に２つの池がある場合、どちらの池に移る確率は等しいとする。
（１）池１にカエルが1匹いるとき、このカエルが１００日後はどの池にいる確率が最も高いか。
（２）カエルが池１に1匹、池２に2匹、池3に3匹、池4に4匹、池5に5匹、池6に6匹いるとする。
100日後にもっとも多くのカエルがいる確率が高いのはどの池か。その池のカエルの数の期待値とともに答えよ。
932:１３２人目の素数さん
25/06/19 11:26:01.17 Cb7ur7l1.net
未だに解答されていません
もしかして未解決問題ですか？
いいえ、傑作質問です
（1）nを正整数とする。
n^3+4n^2+3nを6で割った余りを求めよ。
（2）nを正整数とする。
n^3+7n^2+5nを6で割った余りを求めよ。
933:１３２人目の素数さん
25/06/19 12:12:34.74 7SdgEhPl.net
>>887
アンタ医者なんかじゃないだろ
934:１３２人目の素数さん
25/06/19 12:42:27.72 JGDW0Xi7.net
>>888
合同式つかうなりn^3-nで割るなり好きにしろよ。
935:１３２人目の素数さん
25/06/19 12:46:46.54 q4l2IwBj.net
>>887
あんたは早く病院医者板のスレで謝罪しろ
936:１３２人目の素数さん
25/06/19 13:03:46.73 7SdgEhPl.net
A3の医師免許で発狂して以来全く張り合いがないね尿瓶ジジイ>>887
937:１３２人目の素数さん
25/06/19 15:32:57.26 BgaX8qG8.net
>>890
解答を記述しなさい。
938:１３２人目の素数さん
25/06/19 19:11:10.99 BgaX8qG8.net
a^2+b^2=c^3+d^3
を満たす正整数の組(a,b,c,d)は無数に存在するか。
939:１３２人目の素数さん
25/06/19 21:12:59.86 scvOAOQ6.net
>>893
方針説明されてもわからないとか理解力なさ過ぎだろwwww
940:１３２人目の素数さん
25/06/20 05:07:31.24 lixCBOqW.net
自分の頭の中にある解答と正確に一致するまで
止まらないというだけ
触れるな
941:１３２人目の素数さん
25/06/20 10:20:25.79 H9bDP
942:Tb3.net
943:１３２人目の素数さん
25/06/20 10:21:40.02 H9bDPTb3.net
>>895
方針の説明は解答ではありません。
944:１３２人目の素数さん
25/06/20 10:22:09.15 H9bDPTb3.net
>>896
いいえ、別解ももちろん許容しております。
945:１３２人目の素数さん
25/06/20 10:33:06.75 MF6ybfWx.net
>>898
質問スレなのに解答要求www
解き方分かってるのになんで解答必要なのか合理的な理由述べてみろよ。
946:１３２人目の素数さん
25/06/20 15:41:32.93 YJQocZkG.net
>>900
解き方は分かっていません
もしかしたら未解決問題かもしれませんよ
947:１３２人目の素数さん
25/06/21 08:47:11.33 dWmZZosR.net
>>901
未解決問題wwww
何処がだよ。
解き方も説明されてるだろwww
948:１３２人目の素数さん
25/06/21 09:28:01.28 gIBPITlW.net
どこからどう見てもクソつまらない考えるだけ無駄な最底辺のバカが思いついた糞問を良問に見せかける解答をしろ、という問題だよ
難しいと思うけどな
949:１３２人目の素数さん
25/06/21 14:04:17.63 TCVt3Th+.net
この質問が傑作である理由を説明します
（1）は因数分解だけで解けます
しかし（2）は因数分解できません
その工夫が大学受験生にとっては丁度よい難易度となっており、（1）からインスピレーションを得ることもでき、傑作なのです
（1）nを正整数とする。
n^3+4n^2+3nを6で割った余りを求めよ。
（2）nを正整数とする。
n^3+7n^2+5nを6で割った余りを求めよ。
950:１３２人目の素数さん
25/06/21 18:30:36.62 o0NLVsTG.net
>>904
理由www
何処が傑作なんだよwww
簡単な総当たりで解ける問題なんか傑作とは言えないな
951:１３２人目の素数さん
25/06/21 18:36:58.90 TCVt3Th+.net
>>905
難易度調整が必要なことをご理解ください
京都大学の文系第1問はこれよりも易しいのです
現代の大学入試事情を鑑みて、この程度の難易度にしております
952:１３２人目の素数さん
25/06/21 18:47:37.84 iVrSlwPC.net
>>904
傑作だと思ってるアンタが一番傑作
953:１３２人目の素数さん
25/06/21 19:18:01.22 TCVt3Th+.net
>>907
難易度調整が必要なことをご理解ください
京都大学の文系第1問はこれよりも易しいのです
現代の大学入試事情を鑑みて、この程度の難易度にしております
954:１３２人目の素数さん
25/06/21 20:12:22.62 iVrSlwPC.net
>>908
話通じてない
日本語も不自由みたいだね
955:１３２人目の素数さん
25/06/22 04:51:06.82 B6ITpw6T.net
>>906
難易度調整www
秒で終わるだろ
調整できてねぇwww
956:１３２人目の素数さん
25/06/22 09:12:46.36 /sdPvP+o.net
Fランの方は投稿をご遠慮ください。
プログラムが弄れる医者や東大卒なら自力で算出できる問題。
Fランや裏口シリツ医には無理。
直線上にならんだ池が６個ある。１～６と命名する。
池にはカエルがいる。
観察の結果、カエルは翌日には５０％の確率で隣の池に移る。
隣に２つの池がある場合、どちらの池に移る確率は等しいとする。
（１）池１にカエルが1匹いるとき、このカエルが１００日後はどの池にいる確率が最も高いか。
（２）カエルが池１に1匹、池２に2匹、池3に3匹、池4に4匹、池5に5匹、池6に6匹いるとする。
100日後にもっとも多くのカエルがいる確率が高いのはどの池か。その池のカエルの数の期待値とともに答えよ。
957:１３２人目の素数さん
25/06/22 09:49:30.35 41rWB7Rs.net
>>911
アンタ脳内医者バレたのにまだいたんだ
958:１３２人目の素数さん
25/06/22 11:13:03.25 V0T0lOP1.net
>>911
設定ぐらいきちんとしろ
問題文すらまともに書けないのかよwww
959:１３２人目の素数さん
25/06/22 11:13:13.52 lVTJ2xwJ.net
>９０９の計算ができないようなFランの方は投稿をご遠慮ください。
960:１３２人目の素数さん
25/06/22 11:14:49.70 6D/H02PK.net
>>913
AIはちゃんと計算するよ。
Ｆランには無理みたいだけどね。
961:１３２人目の素数さん
25/06/22 11:18:18.20 x1q6L9ud.net
Rだと小数に表示なのでMathematicaで計算。
80353937215217784622318561352545314301219984594089748478819
Out[4]= {------------------------------------------------------------,
803469022129495137770981046170581301261101496891396417650688
20088148412335002790621607242593839987034997410025084906975
> ------------------------------------------------------------,
100433627766186892221372630771322662657637687111424552206336
40174538074102937850551109060704760584515594716727372518775
> ------------------------------------------------------------,
962:200867255532373784442745261542645325315275374222849104412672 20086182069423287937895596774418478938984256623118935282825 > ------------------------------------------------------------, 100433627766186892221372630771322662657637687111424552206336 160682421553118032860967525489926293991268384984698970271425 > ------------------------------------------------------------, 803469022129495137770981046170581301261101496891396417650688 1255310425166894422771138921081126550349948690321031989171 > -----------------------------------------------------------} 12554203470773361527671578846415332832204710888928069025792 In[5]:= N@ans1 Out[5]= {0.100009, 0.200014, 0.200005, 0.199995, 0.199986, 0.0999912} In[6]:= Flatten@Position[ans1,Max[ans1]] Out[6]= {2} In[7]:=
963:１３２人目の素数さん
25/06/22 11:20:52.91 2CFzB4x4.net
小数に表示って何？
964:１３２人目の素数さん
25/06/22 11:29:15.33 VNaddM8B.net
>>915
AIに騙されたのにまだ縋ってるんだ
965:１３２人目の素数さん
25/06/22 11:31:48.23 VNaddM8B.net
てか出題されじゃなく質問スレなんだけど
日本語も読めないのかよ
Fランだってスレタイくらい読めるし理解できるぞ
966:１３２人目の素数さん
25/06/22 11:42:53.11 V0T0lOP1.net
>>915
AIは問題文がおかしいかどうかなんて判定してくれないぞwww
仮定が不足してても適当に誤魔化して答えるだけだ
それすら分からないのクズすぎん？
967:１３２人目の素数さん
25/06/22 12:37:55.33 AY7cZjkg.net
>>919
出題はしておりません
質問をしております
968:１３２人目の素数さん
25/06/22 12:38:56.58 AY7cZjkg.net
この質問は出題ではありません
また、京都大学文系第1問よりは難度の高い問題となっております。
解答をお待ちしております
（1）nを正整数とする。
n^3+4n^2+3nを6で割った余りを求めよ。
（2）nを正整数とする。
n^3+7n^2+5nを6で割った余りを求めよ。
969:１３２人目の素数さん
25/06/22 12:40:29.36 AY7cZjkg.net
定積分
∫[a,b] cos(x-(ab/x)) dx
を求めよ。
970:１３２人目の素数さん
25/06/22 13:09:39.43 2CFzB4x4.net
>>921
AIが答えてくれたんでしょ？ならもういいじゃん
971:１３２人目の素数さん
25/06/22 13:20:05.55 AY7cZjkg.net
>>924
AIは解答を出しておりません
972:１３２人目の素数さん
25/06/22 13:28:47.80 DRKE+jFQ.net
医者東大卒専用が聞いて呆れる
日本語読めないチンパンが発狂してるだけのスレ
973:１３２人目の素数さん
25/06/22 13:39:18.05 DRKE+jFQ.net
>>914
じゃあアンタが解いてみろよ
解けないアンタはfランだからさっさと消えろ
974:１３２人目の素数さん
25/06/22 13:50:35.65 DRKE+jFQ.net
あ、元々頭と問題文がおかしいから答えなんて出るわけないかww
975:１３２人目の素数さん
25/06/22 14:45:26.91 AY7cZjkg.net
この質問は出題ではありません
また、京都大学文系第1問よりは難度の高い問題となっております。
解答をお待ちしております
（1）nを正整数とする。
n^3+4n^2+3nを6で割った余りを求めよ。
（2）nを正整数とする。
n^3+7n^2+5nを6で割った余りを求めよ。
976:１３２人目の素数さん
25/06/22 14:51:29.60 AY7cZjkg.net
>>929
この質問に解答があるまで問い続けます
問い続けることはギリシア時代から智の妙とされてきました
977:１３２人目の素数さん
25/06/22 14:56:31.95 DRKE+jFQ.net
>>930
ただの日本語通じないレス乞食の分際で医者東大卒とか笑わせんな
978:１３２人目の素数さん
25/06/22 15:00:23.16 eikMm3+0.net
やってみな
医者もどきは1つの確率の問題で12年粘着した
年季が違うんだよ
979:１３２人目の素数さん
25/06/22 16:10:21.68 AY7cZjkg.net
>>932
そこまで非常識ではありませんよ
傑作質問が解かれないことに悲しみを覚えているだけです
980:１３２人目の素数さん
25/06/22 16:12:06.99 x2oHaXeR.net
>>933
アンタは何年レス乞食するのかな
981:１３２人目の素数さん
25/06/22 17:02:10.32 AY7cZjkg.net
>>934
早く解いてくださればいいのにと思います
まあ私が解いても良いのですが、それでは採点し甲斐がありませんし
982:１３２人目の素数さん
25/06/22 17:04:39.80 AY7cZjkg.net
傑作質問が頭の中に次々と浮かんできます
明日から1日1問、質問してもいいですか？
983:１３２人目の素数さん
25/06/22 17:17:38.52 2CFzB4x4.net
>>936
何故出題スレを使わないのですか？
984:１３２人目の素数さん
25/06/22 18:18:54.81 x2oHaXeR.net
>>937
バカだから
985:１３２人目の素数さん
25/06/22 18:19:30.97 DRKE+jFQ.net
>>93
986:5 まず日本語の勉強からしろよ通じてないんだから
987:１３２人目の素数さん
25/06/22 20:41:35.43 AY7cZjkg.net
>>937
すいません、怒らないでくださいね
このスレのみんなってバカだから相手してくれるじゃないですか笑
だから投稿するんですよ
988:１３２人目の素数さん
25/06/22 21:23:11.12 b81U4F44.net
数学やってるつもりのレス乞食のバカがバカにされてるだけ
989:１３２人目の素数さん
25/06/23 12:01:39.29 N+N6PUun.net
iを虚数単位、a,bを相異なる素数、pを素数とする。
(a+bi)^pは実数でないことを示せ。
990:１３２人目の素数さん
25/06/23 13:40:43.12 Tck83ouL.net
>>942
スレチ
991:１３２人目の素数さん
25/06/23 19:57:14.97 ZC1ubWRF.net
>>943
すいません、質問しているのですが、なにがスレチなのでしょうか？
992:１３２人目の素数さん
25/06/23 21:11:44.61 M0hbgrJj.net
私の質問に解答していただけた場合、
20点を満点として採点いたします
採点基準は東京大学理系数学を採点する場合と同じ基準を想定いたします
993:１３２人目の素数さん
25/06/23 21:38:33.62 3REuqFh0.net
>>945
想定www
独りよがり思い込み評価とかゴミクズそのものwwww
994:１３２人目の素数さん
25/06/23 21:39:01.91 W1fWik/d.net
>>945
アンタの日本語力は0点みたいだね
995:１３２人目の素数さん
25/06/23 22:53:24.93 M0hbgrJj.net
質問（20点）
iを虚数単位、a,bを相異なる素数、pを素数とする。
(a+bi)^pは実数でないことを示せ。
996:１３２人目の素数さん
25/06/23 23:18:23.72 WUOXKJyZ.net
>>944
それがわからないのは医師でも東大卒でもないのでやはりスレチ
997:１３２人目の素数さん
25/06/26 15:47:46.29 pTYKrk0b.net
いい加減にこのスレを機能させなさい。
高校生からの質問が来るようスレを整えなさい。
傑作質問への解答を行いなさい。
998:１３２人目の素数さん
25/06/26 16:15:09.65 SLQwJWmw.net
>>950
尿瓶が死んだから荒れなくていいだろ