r - 当 x 已知时，求两条曲线相交处的 y 坐标

Question

背景及目的概要

我正在尝试使用 R 找到两条绘制曲线相交处的 y 坐标。我将在下面提供完整的详细信息和示例数据，但希望这是一个简单的问题，我会在前面更简洁。

两条曲线的累积频率(为简单起见为 c1 和 c2)由以下函数定义，其中 a 和 b 是已知系数:
f(x)=1/(1+exp(-(a+bx)))

使用 uniroot() 函数，我在 c1 和 c2 的交叉点找到了“x”。

我假设如果 x 是已知的，那么确定 y 应该是简单的替换:例如，如果 x = 10，y=1/(1+exp(-(a+b*10)))(同样，a 和 b 是已知值)；然而，如下文所示，情况并非如此。

这篇文章的目的是确定如何找到 y 坐标。

细节

该数据复制了受访者的陈述价格，他们认为产品的价格太便宜(即他们质疑其质量)以及他们认为产品便宜的价格。

数据在使用前会被清理干净，以确保too.cheap是
总是低于便宜的价格。

的累积频率
讨价还价的价格将倒转为不讨价还价。

讨价还价和too.cheap的交点将代表点在
同等比例的受访者认为价格不便宜
和too.cheap ---边际便宜点(“pmc”)。

到达我遇到挑战的地步将需要许多步骤。

第 1 步:生成一些数据

# load libraries for all steps
library(car)
library(ggplot2)

# function that generates the data
so.create.test.dataset <- function(n, mean){

  step.to.bargain <- round(rnorm(n = n, 3, sd = 0.75), 2)
  price.too.cheap <- round(rnorm(n = n, mean = mean, sd = floor(mean * 100 / 4) / 100), 2)
  price.bargain <- price.too.cheap + step.to.bargain 

  df.temp <- cbind(price.too.cheap,
                 price.bargain)
  df.temp <- as.data.frame(df.temp)

  return(df.temp)
}
# create 389 "observations" where the too.cheap has a mean value of 10.50
# the function will also create a "bargain" price by 
#adding random values with a mean of 3.00 to the too.cheap price

so.test.df <- so.create.test.dataset(n = 389, mean = 10.50)

第二步:创建一个累积频率的数据框

so.get.count <- function(p.points, p.vector){
  cc.temp <- as.data.frame(table(p.vector))
  cc.merged <- merge(p.points, cc.temp, by.x = "price.point", by.y = "p.vector", all.x = T)
  cc.extracted <- cc.merged[,"Freq"]
  cc.extracted[is.na(cc.extracted)] <- 0
  return(cc.extracted)
}

so.get.df.price<-function(df){
  # creates cumulative frequencies for three variables 
  # using the price points provided by respondents

  # extract and sort all unique price points
  # Thanks to akrun for their help with this step
  price.point <- sort(unique(unlist(round(df, 2))))

  #create a new data frame to work with having a row for each price point
  dfp <- as.data.frame(price.point)

  # Create cumulative frequencies (as percentages) for each variable
  dfp$too.cheap.share <- 1 - (cumsum(so.get.count(dfp, df$price.too.cheap)) / nrow(df))
  dfp$bargain.share <- 1 - cumsum(so.get.count(dfp, df$price.bargain)) / nrow(df)
  dfp$not.bargain.share <- 1 - dfp$bargain.share# bargain inverted so curves will intersect

  return(dfp)  
} 

so.df.price <- so.get.df.price(so.test.df)

步骤 3:估计累积频率的曲线

# Too Cheap
so.l <- lm(logit(so.df.price$too.cheap.share,  percents = TRUE)~so.df.price$price.point)
so.cof.TCh <- coef(so.l)
so.temp.nls <- nls(too.cheap.share ~ 1 / (1 + exp(-(a + b * price.point))), start = list(a = so.cof.TCh[1], b = so.cof.TCh[2]), data = so.df.price, trace = TRUE)
so.df.price$Pr.TCh <- predict(so.temp.nls, so.df.price$price.point, lwd=2)

#Not Bargain
so.l <- lm(logit(not.bargain.share, percents = TRUE) ~ price.point, so.df.price)
so.cof.NBr <- coef(so.l)
so.temp.nls <- nls(not.bargain.share ~ 1 / (1 + exp(-(a + b * price.point))), start = list(a = so.cof.NBr[1], b = so.cof.Br[2]), data= so.df.price, trace=TRUE)
so.df.price$Pr.NBr <- predict(so.temp.nls, so.df.price$price.point, lwd=2)

# Thanks to John Fox & Sanford Weisberg - "An R Companion to Applied Regression, second edition"

在这一点上，我们可以绘制和比较“观察到的”累积频率与估计频率

ggplot(data = so.df.price, aes(x = price.point))+
  geom_line(aes(y = so.df.price$Pr.TCh, colour = "Too Cheap"))+
  geom_line(aes(y = so.df.price$Pr.NBr, colour = "Not Bargain"))+
  geom_line(aes(y = so.df.price$too.cheap.share, colour = "too.cheap.share"))+
  geom_line(aes(y = so.df.price$not.bargain.share, colour = "not.bargain.share"))+
  scale_y_continuous(name = "Cummulative Frequency")

估计值似乎与观测值吻合得相当好。

第 4 步:找到两个估计函数的交点

so.f <- function(x, a, b){
  # model for the curves
  1 / (1 + exp(-(a + b * x)))
} 
# note, this function may also be used in step 3 
#I was building as I went and I don't want to risk a transpositional error that breaks the example

so.pmc.x <- uniroot(function(x) so.f(x, so.cof.TCh[1], so.cof.TCh[2]) - so.f(x, so.cof.Br[1], so.cof.Br[2]), c(0, 50), tol = 0.01)$root

我们可以通过绘制两个估计值来直观地测试 so.pmc.x。如果正确，那么so.pmc.x 的垂直线应该通过too.cheap 和not.bargain 的交点。

ggplot(data = so.df.price, aes(x = price.point)) +
  geom_line(aes(y = so.df.price$Pr.TCh, colour = "Too Cheap")) +
  geom_line(aes(y = so.df.price$Pr.NBr, colour = "Not Bargain")) +
  scale_y_continuous(name = "Cumulative Frequency") +
  geom_vline(aes(xintercept = so.pmc.x))

...确实如此。

第 5 步:找到 y

这就是我被难住的地方，我敢肯定我忽略了一些非常基本的东西。

如果一条曲线由 f(x) = 1/(1+exp(-(a+bx))) 定义，并且 a、b 和 x 都是已知的，那么 y 不应该是 1/(1 +exp(-(a+bx))) 对于任一估计？

在这种情况下，事实并非如此。

# We attempt to use the too.cheap estimate to find y
so.pmc.y <- so.f(so.pmc.x, so.cof.TCh[1], so.cof.TCh[2])

# In theory, y for not.bargain at price.point so.pmc.x should be the same
so.pmc.y2 <- so.f(so.pmc.x, so.cof.NBr[1], so.cof.NBr[2])

编辑:这是发生错误的地方(请参阅下面的解决方案)。
a != so.cof.NBr[1] 和 b != so.cof.NBr[2]，而不是 a 和 be 应该定义为来自 so.temp.nls(不是 so.l)的系数

# Which they are
#> so.pmc.y
#(Intercept) 
# 0.02830516 
#> so.pmc.y2
#(Intercept) 
#  0.0283046 

如果我们计算 y 的正确值，yintercept = so.pmc.y 处的水平线应该通过 too.cheap 和 not.bargain 的交点。



...这显然不是。

那么如何估计 y 呢？

Answer 1

我已经解决了这个问题，正如我怀疑的那样，这是一个简单的错误。

我的假设 y = 1/(1+exp(-(a+bx))) 是正确的。

问题是我使用了错误的 a, b 系数。

我的曲线是使用 so.cof.NBr 中由 so.l 定义的系数定义的。

#Not Bargain
so.l <- lm(logit(not.bargain.share, percents = TRUE) ~ price.point, so.df.price)
so.cof.NBr <- coef(so.l)
so.temp.nls <- nls(not.bargain.share ~ 1 / (1 + exp(-(a + b * price.point))), start = list(a = so.cof.NBr[1], b = so.cof.Br[2]), data= so.df.price, trace=TRUE)
so.df.price$Pr.NBr <- predict(so.temp.nls, so.df.price$price.point, lwd=2)

但结果曲线是 so.temp.nls，而不是 so.l。

因此，一旦我找到 so.pmc.x，我需要从 so.temp.nls 中提取正确的系数并使用它们来找到 y。

# extract coefficients from so.temp.nls
so.co <- coef(so.temp.nls)

# find y
so.pmc.y <- 1 / (1 + exp(-(so.co[1] + so.co[2] * so.pmc.x)))

ggplot(data = so.df.price, aes(x = price.point))+
  geom_line(aes(y = so.df.price$Pr.TCh, colour = "Too Cheap"))+
  geom_line(aes(y = so.df.price$Pr.NBr, colour = "Not Bargain"))+
  scale_y_continuous(name = "Cumulative Frequency")+
  geom_hline(aes(yintercept = so.pmc.y))

产生以下...



它以图形方式描绘了正确答案。