16-09-2020, R - rextester

Language: Layout:

# Ajuste de curvas por mínimos quadrados.

# Dados os vetores x e y, supomos que y_i=f(x_i)+erro_i, como erro_i um erro "pequeno".
x=seq(-5,5,by=0.5);x  
n=length(x)

y=c( 0.1617647, 0.1701807, 0.1818182, 0.1985294, 0.2236842, 0.2638889, 0.3333333,
 0.4659091, 0.7500000,  1.3750000, 2.0000000, 1.3750000, 0.7500000, 0.4659091, 0.3333333,
 0.2638889, 0.2236842, 0.1985294, 0.1818182, 0.1701807, 0.1617647)

plot(x,y,col="red")

# Suponha que y=f(x) (aproximado) e que f(s)=(a+bs^2)/(c+ds^2). Descobrir aproximações para a, b, c e d.
#
# (c+ds^2)f(s)=(a+bs^2) ou f(s)=-df(s)s^2/c+a/c+bs^2/c. Mudança de variável a_1=a/c, b_1=b/c, d_1=-d/c e 
# g_1(s)=f(s)s^2, e podemos escrever
#
# f(s)=a_1+b_1s^2+d_1 g_1(s). Determinar a_1, b_1 e d_1.

# Note que 
#            f(s)=(a+bs^2)/(c+ds^2)=(a/c+bs^2/c)/(1+ds^2/c)=(a_1+b_1s^2)/(1-d_1s^2).

# Preciso costruir g_1(x_i)=y_i*x_i^2 e minimizar a função

# |Au-y|^2, em que A matriz, cuja linha i é o vetor c(1,x_i^2, y_i*x_i^2).

# Resolver o sistema linear A^*(Au-y)=A^*Au-A^*y=0 pelo método dos gradientes conjugados.

A=matrix(0,n,3); v=0*x;
for ( i in 1:n){A[i,]=c(1,x[i]^2,y[i]*x[i]^2);v[i]=y[i]}

gmv<-function(u){  #  |Au-v|^2 / 2
w=A%*%u-v; t(w)%*%w/2}

gmv(c(1,6,3))     # Teste de g(u), com mudança de variável.

# Agora é conhecido que o gradiente de g(u) é dado por A^*(Au-v).
#
# Como o problema é linear, vamos resolver pelo Método de decomposição A=QR.
# Isso nos leva a resolver a equação Ru=t(Q)v.

# ---------------Processo de ortogonalização de Gram-Schmdit

pe<-function(u,v){ # Dados os vetores u e v, somo o produto de cada coordenada de u com a respectiva cooordenada de v.
n=length(u)
p=u[1]*v[1]
for ( i in 2:n){p=p+u[i]*v[i]}
p
}

mod<-function(u){sqrt(pe(u,u))}  # módulo de u

proj<-function(u,v){pe(u,v)*v}  # Projeção de u sobre v (ortogonal), com norma de v igual 1

GramS<-function(A){  # Ortogonliza as colunas de A
n=length(A[1,])

Q=0*A

Q[,1]=A[,1]/mod(A[,1])

for (i in 2:n){
p=A[,i]
for (j in 1:(i-1)){
p=p-proj(A[,i],Q[,j])
}
Q[,i]=p/mod(p)
}

Q
}

Q=GramS(A); print("Matriz Q"); Q

t(Q)%*%Q      # Teste de ortogonalização

R=t(Q)%*%A; print("Matriz R"); R

#------ Resolução de sistema triangular Ru=t(Q)v.

TSup<-function(A,b){
p=0*b; n=length(b)
p[n]=b[n]/A[n,n]
for (i in (n-1):1){
q=b[i]
for (j in n:(i+1)){
q=q-A[i,j]*p[j]
}
p[i]=q/A[i,i]
}
p
}

v=t(Q)%*%y;v
u=TSup(R,v)
#---------------------------------------------------------------------------------------

print("Soulução") ; u                                # Aproximação para u que minimisa |Au-v|^2.

fapmv<-function(s){(u[1]+u[2]*s^2)/(1-u[3]*s^2)}  # Aproximação da função linearizada.

curve(fapmv,-5,5)                           # Teste de ajuste
points(x,y,col="red")

[ + ] Show input
Absolute running time: 0.76 sec, cpu time: 0.94 sec, memory peak: 51 Mb, absolute service time: 0,99 sec