В R найдите нелинейные линии из двух наборов точек, а затем найдите пересечение этих точек - PullRequest
0 голосов
/ 02 июня 2019

Используя R, я хочу оценить две кривые, используя точки из двух векторов, а затем найти координаты x и y, где эти расчетные кривые пересекаются.

В стратегической обстановке с игроками "t" и "p" я моделирую лучшие ответы для обоих игроков в ответ на то, что другой выберет в стратегической обстановке (теория игр). Проблема в том, что у меня нет функций или линий, у меня есть два набора точек, происходящих из симуляции, причем один набор точек соответствует наилучшему ответу игрока на заданные действия другого игрока. Фактическая математика была для меня (или matlab) слишком сложной для решения, поэтому я использую этот смоделированный визуальный подход. Я хочу оценить функции наилучшего отклика (т.е. создать нелинейные кривые), используя точки, а затем взять две расчетные кривые и найти, где они пересекаются, чтобы определить равновесие Нэша (где пересекаются кривые наилучшего отклика).

Например, вот два таких вектора, с которыми я работаю:

t=c(10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.1,10.1,10.1,10.1,10.1,10.1,10.1,10.1,10.1,10.1,10.1,10.1,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0,10.0)

p=c(12.3,12.3,12.3,12.3,12.3,12.3,12.4,12.4,12.4,12.5,12.5,12.5,12.6,12.6,12.7,12.7,12.8,12.8,12.9,12.9,13.0,13.1,13.1,13.2,13.3,13.4,13.5,13.4,13.5,13.6,13.6,13.7,13.8,13.8,13.9,13.9,13.9,14.0,14.0,14.0,14.0)

Для первой строки выборка состоит из (t, a), а для второй строки выборка состоит из (a, p), где a - третий вектор, заданный

a = seq(10, 14, by = 0.1)

Например, первая точка для выборки, соответствующей первому вектору, будет (10.0,10.0), а вторая точка будет (10.0,10.1). Первая точка для выборки, соответствующей второму вектору, будет (10.0,12.3), а вторая точка будет (10.1,12.3).

То, что я первоначально пытался сделать, это оценить линии с использованием полиномов, созданных моделями lm, но они, кажется, не всегда работают:

plot(a,t, xlim=c(10,14), ylim=c(10,14), col="purple")
points(p,a, col="red")

fit4p <- lm(a~poly(p,3,raw=TRUE))
fit4t <- lm(t~poly(a,3,raw=TRUE))
lines(a, predict(fit4t, data.frame(x=a)), col="purple", xlim=c(10,14), ylim=c(10,14),type="l",xlab="p",ylab="t")
lines(p, predict(fit4p, data.frame(x=a)), col="green")

fit4pCurve <- function(x) coef(fit4p)[1] +x*coef(fit4p)[2]+x^2*coef(fit4p)[3]+x^3*coef(fit4p)[4] 
fit4tCurve <- function(x) coef(fit4t)[1] +x*coef(fit4t)[2]+x^2*coef(fit4t)[3]+x^3*coef(fit4t)[4]

a_opt1 = optimise(f=function(x) abs(fit4pCurve(x)-fit4tCurve(x)), c(10,14))$minimum
b_opt1 = as.numeric(fit4pCurve(a_opt1))

EDIT: После исправления типа я получаю правильный ответ, но он не всегда работает, если образцы возвращаются не так чисто.

Так что мой вопрос можно разбить несколькими способами. Во-первых, есть ли лучший способ выполнить то, что я пытаюсь сделать. Я знаю, что то, что я делаю, не совсем точно, но это похоже на достойное приближение для моих целей. Во-вторых, если нет лучшего способа, могу ли я улучшить методологию, которую я перечислил выше.

1 Ответ

0 голосов
/ 02 июня 2019

Перезапустите сеанс R, убедитесь, что все переменные очищены, и скопируйте / вставьте этот код. Я нашел несколько ошибок в ссылочных переменных. Также обратите внимание, что R чувствителен к регистру. Я подозреваю, что вы перезаписывали переменные.

plot(a,t, xlim=c(10,14), ylim=c(10,14), col="purple")
points(p,a, col="red")

fit4p <- lm(a~poly(p,3,raw=TRUE))
fit4t <- lm(t~poly(a,3,raw=TRUE))
lines(a, predict(fit4t, data.frame(x=a)), col="purple", xlim=c(T,P), ylim=c(10,14),type="l",xlab="p",ylab="t")
lines(p, predict(fit4p, data.frame(x=a)), col="green")

fit4pCurve <- function(x) coef(fit4p)[1] +x*coef(fit4p)[2]+x^2*coef(fit4p)[3]+x^3*coef(fit4p)[4] 
fit4tCurve <- function(x) coef(fit4t)[1] +x*coef(fit4t)[2]+x^2*coef(fit4t)[3]+x^3*coef(fit4t)[4]

a_opt = optimise(f=function(x) abs(fit4pCurve(x)-fit4tCurve(x)), c(T,P))$minimum
b_opt = as.numeric(fit4pCurve(a_opt))

Как вы увидите:

> a_opt
[1] 12.24213
> b_opt
[1] 10.03581
...