Gab1B, R - rextester

Gab1B

# 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(1930,2010,by=10)
n=length(x)

y=c(0.63,0.76,0.92,1.1,1.2,1.3,1.5,1.7,1.9)

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

# Suponha que y=f(x) (aproximado) e que f(s)= a/(b+ce^(-as)) e f'(s)=(a-bf(s))f(s). Descobrir aproximações para a, b e c.
# 
# Note que f(0) nos dá c, caso conhecermos a e b.
# 
# Para determinar os valores dos parâmetros resolvemos o problema de minimização 
#
#        min g(u)
# 
# em que g(u)= sum (y_i-f(x_i))^2, sendo u=(a,b,c(a,b)).
# 
# Para fazer isso usamos o método de Euler para resolver a equaçõ diferencial 
#
#      u'(t)=-grad g(u(t))
#      u(0)=u_0

# Seguem os comando para as definições de funções necessárias.

# Ajuste linearizado 
#
# Mudança de ajuste f'(s) = (y_(i+1)-y_i)/(x_(i+1)-x_i)=(a-by_i)y_i. Isso produz a relação . Determinar a e b.

# Minimizar |Au-v|^2, em que A matriz, cuja linha i é o vetor c(y_i,y_i^2) e v_i=(y_(i+1)-y_i)/(x_(i+1)-x_i).

# Resolver o sistema linear A^*(Au-v)=A^*Au-A^*v=0 pelo método A=QR.

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

print("Matriz A");A
print("vetor v");v

# 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)%*%v;v
u=TSup(R,v)
#---------------------------------------------------------------------------------------

print("Soulução") ; u                                # Aproximação para u que minimisa |Au-v|^2.
a=u[1]; b=u[2]

c=(a-y[1]*b)/y[1]

print("Parâmetros a, b, c, e d encontrados"); a;b;c
fapmv<-function(s){a/(b+c*exp(-a*(s-1930)))}  # Aproximação da função linearizada.

print("Gráfico para ajuste")
curve(fapmv,1930,2010)                           # Teste de ajuste
points(x,y,col="red")

print("População estimada em 2008");fapmv(2021)


run \| edit \| history \| help	0